derivations: Introduce 'graft' record type.

* guix/derivations.scm (<graft>): New record type.
  (graft-derivation): Rename 'replacements' to 'grafts', and expect it
  to be a list of <graft> records.  Adjust accordingly.
* tests/derivations.scm ("graft-derivation"): Use 'graft' instead of
  pairs in argument to 'graft-derivation'.
This commit is contained in:
Ludovic Courtès 2014-10-14 14:47:49 +02:00
parent e25408849a
commit 969df97487
3 changed files with 45 additions and 21 deletions

View File

@ -25,6 +25,7 @@
(eval . (put 'origin 'scheme-indent-function 0)) (eval . (put 'origin 'scheme-indent-function 0))
(eval . (put 'build-system 'scheme-indent-function 0)) (eval . (put 'build-system 'scheme-indent-function 0))
(eval . (put 'bag '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 'operating-system 'scheme-indent-function 0))
(eval . (put 'file-system 'scheme-indent-function 0)) (eval . (put 'file-system 'scheme-indent-function 0))
(eval . (put 'manifest-entry 'scheme-indent-function 0)) (eval . (put 'manifest-entry 'scheme-indent-function 0))

View File

@ -30,6 +30,7 @@
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix hash) #:use-module (guix hash)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix records)
#:export (<derivation> #:export (<derivation>
derivation? derivation?
derivation-outputs derivation-outputs
@ -65,7 +66,15 @@
derivation-path->output-path derivation-path->output-path
derivation-path->output-paths derivation-path->output-paths
derivation derivation
graft
graft?
graft-origin
graft-replacement
graft-origin-output
graft-replacement-output
graft-derivation graft-derivation
map-derivation map-derivation
%guile-for-build %guile-for-build
@ -965,23 +974,31 @@ they can refer to each other."
#:guile-for-build guile #:guile-for-build guile
#:local-build? #t))) #: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))) #:key (guile (%guile-for-build)))
"Return a derivation called NAME, based on DRV but with all the first "Return a derivation called NAME, based on DRV but with all the GRAFTS
elements of REPLACEMENTS replaced by the corresponding second element. applied."
REPLACEMENTS must be a list of ((DRV OUTPUT) . (DRV2 OUTPUT)) pairs."
;; XXX: Someday rewrite using gexps. ;; XXX: Someday rewrite using gexps.
(define mapping (define mapping
;; List of store item pairs. ;; List of store item pairs.
(map (match-lambda (map (match-lambda
(((source source-outputs ...) . (target target-outputs ...)) (($ <graft> source source-output target target-output)
(cons (if (derivation? source) (cons (if (derivation? source)
(apply derivation->output-path source source-outputs) (derivation->output-path source source-output)
source) source)
(if (derivation? target) (if (derivation? target)
(apply derivation->output-path target target-outputs) (derivation->output-path target target-output)
target)))) target))))
replacements)) grafts))
(define outputs (define outputs
(match (derivation-outputs drv) (match (derivation-outputs drv)
@ -1013,17 +1030,19 @@ REPLACEMENTS must be a list of ((DRV OUTPUT) . (DRV2 OUTPUT)) pairs."
(define add-label (define add-label
(cut cons "x" <>)) (cut cons "x" <>))
(match replacements (match grafts
(((sources . targets) ...) ((($ <graft> sources source-outputs targets target-outputs) ...)
(build-expression->derivation store name build (let ((sources (zip sources source-outputs))
#:guile-for-build guile (targets (zip targets target-outputs)))
#:modules '((guix build graft) (build-expression->derivation store name build
(guix build utils)) #:guile-for-build guile
#:inputs `(("original" ,drv) #:modules '((guix build graft)
,@(append (map add-label sources) (guix build utils))
(map add-label targets))) #:inputs `(("original" ,drv)
#:outputs output-names ,@(append (map add-label sources)
#:local-build? #t)))) (map add-label targets)))
#:outputs output-names
#:local-build? #t)))))
(define* (build-expression->derivation store name exp (define* (build-expression->derivation store name exp
#:key #:key

View File

@ -831,8 +831,12 @@ Deriver: ~a~%"
(lambda (port) (lambda (port)
(display "fake mkdir" port))))) (display "fake mkdir" port)))))
(graft (graft-derivation %store "graft" orig (graft (graft-derivation %store "graft" orig
`(((,%bash) . (,one)) (list (graft
((,%mkdir) . (,two)))))) (origin %bash)
(replacement one))
(graft
(origin %mkdir)
(replacement two))))))
(and (build-derivations %store (list graft)) (and (build-derivations %store (list graft))
(let ((two (derivation->output-path two)) (let ((two (derivation->output-path two))
(graft (derivation->output-path graft))) (graft (derivation->output-path graft)))