From 969df974871ae1882c25df8d9b09bced2e62a30b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 14 Oct 2014 14:47:49 +0200
Subject: 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'.
---
 .dir-locals.el        |  1 +
 guix/derivations.scm  | 57 ++++++++++++++++++++++++++++++++++-----------------
 tests/derivations.scm |  8 ++++++--
 3 files changed, 45 insertions(+), 21 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index fe1f41c3ed..106c35bce6 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -25,6 +25,7 @@
    (eval . (put 'origin 'scheme-indent-function 0))
    (eval . (put 'build-system '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 'file-system 'scheme-indent-function 0))
    (eval . (put 'manifest-entry 'scheme-indent-function 0))
diff --git a/guix/derivations.scm b/guix/derivations.scm
index c0b69e71d6..15faf59616 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -30,6 +30,7 @@
   #:use-module (guix utils)
   #:use-module (guix hash)
   #:use-module (guix base32)
+  #:use-module (guix records)
   #:export (<derivation>
             derivation?
             derivation-outputs
@@ -65,7 +66,15 @@
             derivation-path->output-path
             derivation-path->output-paths
             derivation
+
+            graft
+            graft?
+            graft-origin
+            graft-replacement
+            graft-origin-output
+            graft-replacement-output
             graft-derivation
+
             map-derivation
 
             %guile-for-build
@@ -965,23 +974,31 @@ they can refer to each other."
                                   #:guile-for-build guile
                                   #: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)))
-  "Return a derivation called NAME, based on DRV but with all the first
-elements of REPLACEMENTS replaced by the corresponding second element.
-REPLACEMENTS must be a list of ((DRV OUTPUT) . (DRV2 OUTPUT)) pairs."
+  "Return a derivation called NAME, based on DRV but with all the GRAFTS
+applied."
   ;; XXX: Someday rewrite using gexps.
   (define mapping
     ;; List of store item pairs.
     (map (match-lambda
-          (((source source-outputs ...) . (target target-outputs ...))
+          (($ <graft> source source-output target target-output)
            (cons (if (derivation? source)
-                     (apply derivation->output-path source source-outputs)
+                     (derivation->output-path source source-output)
                      source)
                  (if (derivation? target)
-                     (apply derivation->output-path target target-outputs)
+                     (derivation->output-path target target-output)
                      target))))
-         replacements))
+         grafts))
 
   (define outputs
     (match (derivation-outputs drv)
@@ -1013,17 +1030,19 @@ REPLACEMENTS must be a list of ((DRV OUTPUT) . (DRV2 OUTPUT)) pairs."
   (define add-label
     (cut cons "x" <>))
 
-  (match replacements
-    (((sources . targets) ...)
-     (build-expression->derivation store name build
-                                   #:guile-for-build guile
-                                   #:modules '((guix build graft)
-                                               (guix build utils))
-                                   #:inputs `(("original" ,drv)
-                                              ,@(append (map add-label sources)
-                                                        (map add-label targets)))
-                                   #:outputs output-names
-                                   #:local-build? #t))))
+  (match grafts
+    ((($ <graft> sources source-outputs targets target-outputs) ...)
+     (let ((sources (zip sources source-outputs))
+           (targets (zip targets target-outputs)))
+       (build-expression->derivation store name build
+                                     #:guile-for-build guile
+                                     #:modules '((guix build graft)
+                                                 (guix build utils))
+                                     #:inputs `(("original" ,drv)
+                                                ,@(append (map add-label sources)
+                                                          (map add-label targets)))
+                                     #:outputs output-names
+                                     #:local-build? #t)))))
 
 (define* (build-expression->derivation store name exp
                                        #:key
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 48d12990e6..e774fed4c3 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -831,8 +831,12 @@ Deriver: ~a~%"
                                                  (lambda (port)
                                                    (display "fake mkdir" port)))))
          (graft (graft-derivation %store "graft" orig
-                                  `(((,%bash) . (,one))
-                                    ((,%mkdir) . (,two))))))
+                                  (list (graft
+                                          (origin %bash)
+                                          (replacement one))
+                                        (graft
+                                          (origin %mkdir)
+                                          (replacement two))))))
     (and (build-derivations %store (list graft))
          (let ((two   (derivation->output-path two))
                (graft (derivation->output-path graft)))
-- 
cgit v1.2.3