[bug#33519] [PATCH 2/4] grafts: Record metadata as derivation properties.

[Ludovic Courtès]

* guix/grafts.scm (graft-derivation/shallow): Pass #:properties to
'build-expression->derivation'.
* tests/grafts.scm ("graft-derivation, grafted item is a direct
dependency"): Check the value returned by 'derivation-properties'.
---
 guix/grafts.scm  |  7 ++++++-
 tests/grafts.scm | 13 ++++++++-----
 2 files changed, 14 insertions(+), 6 deletions(-)

diff --git a/guix/grafts.scm b/guix/grafts.scm
index 01e245d8eb..63f384555b 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -123,6 +123,10 @@ are not recursively applied to dependencies of DRV."
   (define add-label
     (cut cons "x" <>))
 
+  (define properties
+    `((type . graft)
+      (graft (count . ,(length grafts)))))
+
   (match grafts
     ((($ <graft> sources source-outputs targets target-outputs) ...)
      (let ((sources (zip sources source-outputs))
@@ -140,7 +144,8 @@ are not recursively applied to dependencies of DRV."
                                                 ,@(append (map add-label 
sources)
                                                           (map add-label 
targets)))
                                      #:outputs outputs
-                                     #:local-build? #t)))))
+                                     #:local-build? #t
+                                     #:properties properties)))))
 (define (item->deriver store item)
   "Return two values: the derivation that led to ITEM (a store item), and the
 name of the output of that derivation ITEM corresponds to (for example
diff --git a/tests/grafts.scm b/tests/grafts.scm
index abb074d628..f85f3c6913 100644
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -51,7 +51,8 @@
 
 (test-begin "grafts")
 
-(test-assert "graft-derivation, grafted item is a direct dependency"
+(test-equal "graft-derivation, grafted item is a direct dependency"
+  '((type . graft) (graft (count . 2)))
   (let* ((build `(begin
                    (mkdir %output)
                    (chdir %output)
@@ -76,14 +77,16 @@
                                             (origin %mkdir)
                                             (replacement two))))))
     (and (build-derivations %store (list grafted))
-         (let ((two     (derivation->output-path two))
-               (grafted (derivation->output-path grafted)))
+         (let ((properties (derivation-properties grafted))
+               (two        (derivation->output-path two))
+               (grafted    (derivation->output-path grafted)))
            (and (string=? (format #f "foo/~a/bar" two)
                           (call-with-input-file (string-append grafted "/text")
                             get-string-all))
                 (string=? (readlink (string-append grafted "/sh")) one)
                 (string=? (readlink (string-append grafted "/self"))
-                          grafted))))))
+                          grafted)
+                properties)))))
 
 (test-assert "graft-derivation, grafted item uses a different name"
   (let* ((build   `(begin
-- 
2.19.1