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.

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")))