derivations: Allow 'map-derivations' to replace sources.

* guix/derivations.scm (map-derivation)[input->output-paths]: Allow
  non-derivation inputs.
  Allow replacements to be store files.  Replace in SOURCES too.
* tests/derivations.scm ("map-derivation, sources"): New test.
This commit is contained in:
Ludovic Courtès 2013-11-13 11:22:07 +01:00
parent f80594cc41
commit a716e36de9
2 changed files with 41 additions and 7 deletions

View File

@ -674,17 +674,21 @@ recursively."
(define input->output-paths (define input->output-paths
(match-lambda (match-lambda
((drv) (((? derivation? drv))
(list (derivation->output-path drv))) (list (derivation->output-path drv)))
((drv sub-drvs ...) (((? derivation? drv) sub-drvs ...)
(map (cut derivation->output-path drv <>) (map (cut derivation->output-path drv <>)
sub-drvs)))) sub-drvs))
((file)
(list file))))
(let ((mapping (fold (lambda (pair result) (let ((mapping (fold (lambda (pair result)
(match pair (match pair
((orig . replacement) (((? derivation? orig) . replacement)
(vhash-cons (derivation-file-name orig) (vhash-cons (derivation-file-name orig)
replacement result)))) replacement result))
((file . replacement)
(vhash-cons file replacement result))))
vlist-null vlist-null
mapping))) mapping)))
(define rewritten-input (define rewritten-input
@ -695,8 +699,10 @@ recursively."
(match input (match input
(($ <derivation-input> path (sub-drvs ...)) (($ <derivation-input> path (sub-drvs ...))
(match (vhash-assoc path mapping) (match (vhash-assoc path mapping)
((_ . replacement) ((_ . (? derivation? replacement))
(cons replacement sub-drvs)) (cons replacement sub-drvs))
((_ . replacement)
(list replacement))
(#f (#f
(let* ((drv (loop (call-with-input-file path read-derivation)))) (let* ((drv (loop (call-with-input-file path read-derivation))))
(cons drv sub-drvs))))))))) (cons drv sub-drvs)))))))))
@ -711,7 +717,13 @@ recursively."
;; Sources typically refer to the output directories of the ;; Sources typically refer to the output directories of the
;; original inputs, INITIAL. Rewrite them by substituting ;; original inputs, INITIAL. Rewrite them by substituting
;; REPLACEMENTS. ;; REPLACEMENTS.
(sources (map (cut substitute-file <> initial replacements) (sources (map (lambda (source)
(match (vhash-assoc source mapping)
((_ . replacement)
replacement)
(#f
(substitute-file source
initial replacements))))
(derivation-sources drv))) (derivation-sources drv)))
;; Now augment the lists of initials and replacements. ;; Now augment the lists of initials and replacements.

View File

@ -720,6 +720,28 @@ Deriver: ~a~%"
(and (build-derivations %store (list (pk 'remapped drv4))) (and (build-derivations %store (list (pk 'remapped drv4)))
(call-with-input-file out get-string-all)))) (call-with-input-file out get-string-all))))
(test-equal "map-derivation, sources"
"hello"
(let* ((script1 (add-text-to-store %store "fail.sh" "exit 1"))
(script2 (add-text-to-store %store "hi.sh" "echo -n hello > $out"))
(bash-full (package-derivation %store (@ (gnu packages bash) bash)))
(drv1 (derivation %store "drv-to-remap"
;; XXX: This wouldn't work in practice, but if
;; we append "/bin/bash" then we can't replace
;; it with the bootstrap bash, which is a
;; single file.
(derivation->output-path bash-full)
`("-e" ,script1)
#:inputs `((,bash-full) (,script1))))
(drv2 (map-derivation %store drv1
`((,bash-full . ,%bash)
(,script1 . ,script2))))
(out (derivation->output-path drv2)))
(and (build-derivations %store (list (pk 'remapped* drv2)))
(call-with-input-file out get-string-all))))
(test-end) (test-end)