futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

derivations: Add 'map-derivation'.

Browse Source 
* guix/derivations.scm (map-derivation): New procedure.
* tests/derivations.scm ("map-derivation"): New test.
This commit is contained in:
Ludovic Courtès 2013-11-13 00:25:57 +01:00
parent 56b943de6e
commit e387ab7c10
2 changed files with 127 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

97
guix/derivations.scm
View File

@ -25,6 +25,7 @@
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 vlist)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix hash)
@ -63,6 +64,7 @@
derivation-path->output-path
derivation-path->output-paths
derivation
map-derivation
%guile-for-build
imported-modules
@ -655,6 +657,101 @@ the build environment in the corresponding file, in a simple text format."
inputs))))
(set-file-name drv file))))
(define* (map-derivation store drv mapping
#:key (system (%current-system)))
"Given MAPPING, a list of pairs of derivations, return a derivation based on
DRV where all the 'car's of MAPPING have been replaced by its 'cdr's,
recursively."
(define (substitute str initial replacements)
(fold (lambda (path replacement result)
(string-replace-substring result path
replacement))
str
initial replacements))
(define (substitute-file file initial replacements)
(define contents
(with-fluids ((%default-port-encoding #f))
(call-with-input-file file get-string-all)))
(let ((updated (substitute contents initial replacements)))
(if (string=? updated contents)
file
;; XXX: permissions aren't preserved.
(add-text-to-store store (store-path-package-name file)
updated))))
(define input->output-paths
(match-lambda
((drv)
(list (derivation->output-path drv)))
((drv sub-drvs ...)
(map (cut derivation->output-path drv <>)
sub-drvs))))
(let ((mapping (fold (lambda (pair result)
(match pair
((orig . replacement)
(vhash-cons (derivation-file-name orig)
replacement result))))
vlist-null
mapping)))
(define rewritten-input
;; Rewrite the given input according to MAPPING, and return an input
;; in the format used in 'derivation' calls.
(memoize
(lambda (input loop)
(match input
(($ <derivation-input> path (sub-drvs ...))
(match (vhash-assoc path mapping)
((_ . replacement)
(cons replacement sub-drvs))
(#f
(let* ((drv (loop (call-with-input-file path read-derivation))))
(cons drv sub-drvs)))))))))
(let loop ((drv drv))
(let* ((inputs (map (cut rewritten-input <> loop)
(derivation-inputs drv)))
(initial (append-map derivation-input-output-paths
(derivation-inputs drv)))
(replacements (append-map input->output-paths inputs))
;; Sources typically refer to the output directories of the
;; original inputs, INITIAL. Rewrite them by substituting
;; REPLACEMENTS.
(sources (map (cut substitute-file <> initial replacements)
(derivation-sources drv)))
;; Now augment the lists of initials and replacements.
(initial (append (derivation-sources drv) initial))
(replacements (append sources replacements))
(name (store-path-package-name
(string-drop-right (derivation-file-name drv)
4))))
(derivation store name
(substitute (derivation-builder drv)
initial replacements)
(map (cut substitute <> initial replacements)
(derivation-builder-arguments drv))
#:system system
#:env-vars (map (match-lambda
((var . value)
`(,var
. ,(substitute value initial
replacements))))
(derivation-builder-environment-vars drv))
#:inputs (append (map list sources) inputs)
#:outputs (map car (derivation-outputs drv))
#:hash (match (derivation-outputs drv)
((($ <derivation-output> _ algo hash))
hash)
(_ #f))
#:hash-algo (match (derivation-outputs drv)
((($ <derivation-output> _ algo hash))
algo)
(_ #f)))))))
;;;
;;; Store compatibility layer.

30
tests/derivations.scm
View File

@ -26,6 +26,7 @@
#:use-module ((guix packages) #:select (package-derivation))
#:use-module ((gnu packages) #:select (search-bootstrap-binary))
#:use-module (gnu packages bootstrap)
#:use-module ((gnu packages guile) #:select (guile-1.8))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
@ -690,6 +691,35 @@ Deriver: ~a~%"
((p2 . _)
(string<? p1 p2)))))))))))))
(test-equal "map-derivation"
"hello"
(let* ((joke (package-derivation %store guile-1.8))
(good (package-derivation %store %bootstrap-guile))
(drv1 (build-expression->derivation %store "original-drv1"
(%current-system)
#f ; systematically fail
'()
#:guile-for-build joke))
(drv2 (build-expression->derivation %store "original-drv2"
(%current-system)
'(call-with-output-file %output
(lambda (p)
(display "hello" p)))
'()))
(drv3 (build-expression->derivation %store "drv-to-remap"
(%current-system)
'(let ((in (assoc-ref
%build-inputs "in")))
(copy-file in %output))
`(("in" ,drv1))
#:guile-for-build joke))
(drv4 (map-derivation %store drv3 `((,drv1 . ,drv2)
(,joke . ,good))))
(out (derivation->output-path drv4)))
(and (build-derivations %store (list (pk 'remapped drv4)))
(call-with-input-file out get-string-all))))
(test-end)