aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2012-07-02 01:23:39 +0200
committerLudovic Courtès <ludo@gnu.org>2012-07-02 01:35:39 +0200
commitd66ac374e9c8c50893b3ac339665259f2f167669 (patch)
treee049c3dab726798b0175d01e642e346450032cc4
parent5f904ffbb1b04adeb57b90d529ed0fac0209e0ff (diff)
downloadguix-d66ac374e9c8c50893b3ac339665259f2f167669.tar
guix-d66ac374e9c8c50893b3ac339665259f2f167669.tar.gz
derivation: Coalesce multiple occurrences of the same input.
* guix/derivations.scm (write-derivation)[coalesce-duplicate-inputs]: New procedure. Use it to process INPUTS. * tests/derivations.scm ("user of multiple-output derivation"): New test.
-rw-r--r--guix/derivations.scm27
-rw-r--r--tests/derivations.scm32
2 files changed, 58 insertions, 1 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 11d47e9702..7f32718048 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -206,6 +206,29 @@ that form."
(define (write-list lst)
(display (list->string lst) port))
+ (define (coalesce-duplicate-inputs inputs)
+ ;; Return a list of inputs, such that when INPUTS contains the same DRV
+ ;; twice, they are coalesced, with their sub-derivations merged. This is
+ ;; needed because Nix itself keeps only one of them.
+ (fold (lambda (input result)
+ (match input
+ (($ <derivation-input> path sub-drvs)
+ ;; XXX: quadratic
+ (match (find (match-lambda
+ (($ <derivation-input> p s)
+ (string=? p path)))
+ result)
+ (#f
+ (cons input result))
+ ((and dup ($ <derivation-input> _ sub-drvs2))
+ ;; Merge DUP with INPUT.
+ (let ((sub-drvs (delete-duplicates
+ (append sub-drvs sub-drvs2))))
+ (cons (make-derivation-input path sub-drvs)
+ (delq dup result))))))))
+ '()
+ inputs))
+
;; Note: lists are sorted alphabetically, to conform with the behavior of
;; C++ `std::map' in Nix itself.
@@ -229,7 +252,7 @@ that form."
(format #f "(~s,~a)" path
(list->string (map object->string
(sort sub-drvs string<?))))))
- (sort inputs
+ (sort (coalesce-duplicate-inputs inputs)
(lambda (i1 i2)
(string<? (derivation-input-path i1)
(derivation-input-path i2))))))
@@ -400,6 +423,8 @@ known in advance, such as a file download."
system builder args env-vars))
(drv (add-output-paths drv-masked)))
+ ;; (write-derivation drv-masked (current-error-port))
+ ;; (newline (current-error-port))
(values (add-text-to-store store (string-append name ".drv")
(call-with-output-string
(cut write-derivation drv <>))
diff --git a/tests/derivations.scm b/tests/derivations.scm
index cdb1942539..097b9d7d28 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -163,6 +163,38 @@
(and (eq? 'one (call-with-input-file one read))
(eq? 'two (call-with-input-file two read)))))))
+(test-assert "user of multiple-output derivation"
+ ;; Check whether specifying several inputs coming from the same
+ ;; multiple-output derivation works.
+ (let* ((builder1 (add-text-to-store %store "my-mo-builder.sh"
+ "echo one > $out ; echo two > $two"
+ '()))
+ (mdrv (derivation %store "multiple-output" (%current-system)
+ "/bin/sh" `(,builder1)
+ '()
+ `((,builder1))
+ #:outputs '("out" "two")))
+ (builder2 (add-text-to-store %store "my-mo-user-builder.sh"
+ "read x < $one;
+ read y < $two;
+ echo \"($x $y)\" > $out"
+ '()))
+ (udrv (derivation %store "multiple-output-user"
+ (%current-system)
+ "/bin/sh" `(,builder2)
+ `(("one" . ,(derivation-path->output-path
+ mdrv "out"))
+ ("two" . ,(derivation-path->output-path
+ mdrv "two")))
+ `((,builder2)
+ ;; two occurrences of MDRV:
+ (,mdrv)
+ (,mdrv "two")))))
+ (and (build-derivations %store (list (pk 'udrv udrv)))
+ (let ((p (derivation-path->output-path udrv)))
+ (and (valid-path? %store p)
+ (equal? '(one two) (call-with-input-file p read)))))))
+
(define %coreutils
(false-if-exception (nixpkgs-derivation "coreutils")))