derivations: Move grafts to (guix grafts).

* guix/derivations.scm (<graft>, graft-derivation, %graft?)
(set-grafting): Move to...
* guix/grafts.scm: ... here.  New file.
* guix/gexp.scm, guix/packages.scm, tests/packages.scm,
guix/scripts/build.scm: Use it.
* Makefile.am (MODULES): Add it.
(SCM_TESTS): Add tests/grafts.scm.
* tests/derivations.scm ("graft-derivation"): Move to...
* tests/grafts.scm: ... here.  New file.

Makefile.am

@@ -49,6 +49,7 @@ MODULES =					\
   guix/serialization.scm			\
   guix/nar.scm					\
   guix/derivations.scm				\
+  guix/grafts.scm				\
   guix/gnu-maintenance.scm			\
   guix/upstream.scm				\
   guix/licenses.scm				\
@@ -220,6 +221,7 @@ SCM_TESTS =					\
   tests/substitute.scm				\
   tests/builders.scm				\
   tests/derivations.scm				\
+  tests/grafts.scm				\
   tests/ui.scm					\
   tests/records.scm				\
   tests/utils.scm				\

guix/derivations.scm

@@ -85,21 +85,11 @@
             derivation-path->output-paths
             derivation
 
-            graft
-            graft?
-            graft-origin
-            graft-replacement
-            graft-origin-output
-            graft-replacement-output
-            graft-derivation
-
             map-derivation
 
             build-derivations
             built-derivations
 
-            %graft?
-            set-grafting
 
             build-expression->derivation)
 
@@ -1111,81 +1101,6 @@ they can refer to each other."
                                   #:guile-for-build guile
                                   #:local-build? #t)))
 
-(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))
-                           (system (%current-system)))
-  "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
-          (($ <graft> source source-output target target-output)
-           (cons (if (derivation? source)
-                     (derivation->output-path source source-output)
-                     source)
-                 (if (derivation? target)
-                     (derivation->output-path target target-output)
-                     target))))
-         grafts))
-
-  (define outputs
-    (match (derivation-outputs drv)
-      (((names . outputs) ...)
-       (map derivation-output-path outputs))))
-
-  (define output-names
-    (match (derivation-outputs drv)
-      (((names . outputs) ...)
-       names)))
-
-  (define build
-    `(begin
-       (use-modules (guix build graft)
-                    (guix build utils)
-                    (ice-9 match))
-
-       (let ((mapping ',mapping))
-         (for-each (lambda (input output)
-                     (format #t "grafting '~a' -> '~a'...~%" input output)
-                     (force-output)
-                     (rewrite-directory input output
-                                        `((,input . ,output)
-                                          ,@mapping)))
-                   ',outputs
-                   (match %outputs
-                     (((names . files) ...)
-                      files))))))
-
-  (define add-label
-    (cut cons "x" <>))
-
-  (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
-                                     #:system system
-                                     #:guile-for-build guile
-                                     #:modules '((guix build graft)
-                                                 (guix build utils))
-                                     #:inputs `(,@(map (lambda (out)
-                                                         `("x" ,drv ,out))
-                                                       output-names)
-                                                ,@(append (map add-label sources)
-                                                          (map add-label targets)))
-                                     #:outputs output-names
-                                     #:local-build? #t)))))
-
 (define* (build-expression->derivation store name exp ;deprecated
                                        #:key
                                        (system (%current-system))
@@ -1353,16 +1268,3 @@ ALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?."
 
 (define built-derivations
   (store-lift build-derivations))
-
-;; The following might feel more at home in (guix packages) but since (guix
-;; gexp), which is a lower level, needs them, we put them here.
-
-(define %graft?
-  ;; Whether to honor package grafts by default.
-  (make-parameter #t))
-
-(define (set-grafting enable?)
-  "This monadic procedure enables grafting when ENABLE? is true, and disables
-it otherwise.  It returns the previous setting."
-  (lambda (store)
-    (values (%graft? enable?) store)))

guix/gexp.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,6 +20,7 @@
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix derivations)
+  #:use-module (guix grafts)
   #:use-module (guix utils)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)

guix/grafts.scm

@@ -0,0 +1,127 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix grafts)
+  #:use-module (guix records)
+  #:use-module (guix derivations)
+  #:use-module ((guix utils) #:select (%current-system))
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:export (graft?
+            graft
+            graft-origin
+            graft-replacement
+            graft-origin-output
+            graft-replacement-output
+
+            graft-derivation
+
+            %graft?
+            set-grafting))
+
+(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))
+                           (system (%current-system)))
+  "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
+          (($ <graft> source source-output target target-output)
+           (cons (if (derivation? source)
+                     (derivation->output-path source source-output)
+                     source)
+                 (if (derivation? target)
+                     (derivation->output-path target target-output)
+                     target))))
+         grafts))
+
+  (define outputs
+    (match (derivation-outputs drv)
+      (((names . outputs) ...)
+       (map derivation-output-path outputs))))
+
+  (define output-names
+    (match (derivation-outputs drv)
+      (((names . outputs) ...)
+       names)))
+
+  (define build
+    `(begin
+       (use-modules (guix build graft)
+                    (guix build utils)
+                    (ice-9 match))
+
+       (let ((mapping ',mapping))
+         (for-each (lambda (input output)
+                     (format #t "grafting '~a' -> '~a'...~%" input output)
+                     (force-output)
+                     (rewrite-directory input output
+                                        `((,input . ,output)
+                                          ,@mapping)))
+                   ',outputs
+                   (match %outputs
+                     (((names . files) ...)
+                      files))))))
+
+  (define add-label
+    (cut cons "x" <>))
+
+  (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
+                                     #:system system
+                                     #:guile-for-build guile
+                                     #:modules '((guix build graft)
+                                                 (guix build utils))
+                                     #:inputs `(,@(map (lambda (out)
+                                                         `("x" ,drv ,out))
+                                                       output-names)
+                                                ,@(append (map add-label sources)
+                                                          (map add-label targets)))
+                                     #:outputs output-names
+                                     #:local-build? #t)))))
+
+
+;; The following might feel more at home in (guix packages) but since (guix
+;; gexp), which is a lower level, needs them, we put them here.
+
+(define %graft?
+  ;; Whether to honor package grafts by default.
+  (make-parameter #t))
+
+(define (set-grafting enable?)
+  "This monadic procedure enables grafting when ENABLE? is true, and disables
+it otherwise.  It returns the previous setting."
+  (lambda (store)
+    (values (%graft? enable?) store)))
+
+;;; grafts.scm ends here

guix/packages.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
 ;;;
@@ -25,6 +25,7 @@
   #:use-module (guix monads)
   #:use-module (guix gexp)
   #:use-module (guix base32)
+  #:use-module (guix grafts)
   #:use-module (guix derivations)
   #:use-module (guix build-system)
   #:use-module (guix search-paths)

guix/scripts/build.scm

@@ -23,6 +23,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix grafts)
   #:use-module (guix utils)
   #:use-module (guix monads)
   #:use-module (guix gexp)

tests/derivations.scm

@@ -929,40 +929,6 @@
                                     ((p2 . _)
                                      (string<? p1 p2)))))))))))))
 
-
-(test-assert "graft-derivation"
-  (let* ((build `(begin
-                   (mkdir %output)
-                   (chdir %output)
-                   (symlink %output "self")
-                   (call-with-output-file "text"
-                     (lambda (output)
-                       (format output "foo/~a/bar" ,%mkdir)))
-                   (symlink ,%bash "sh")))
-         (orig  (build-expression->derivation %store "graft" build
-                                              #:inputs `(("a" ,%bash)
-                                                         ("b" ,%mkdir))))
-         (one   (add-text-to-store %store "bash" "fake bash"))
-         (two   (build-expression->derivation %store "mkdir"
-                                              '(call-with-output-file %output
-                                                 (lambda (port)
-                                                   (display "fake mkdir" port)))))
-         (graft (graft-derivation %store "graft" orig
-                                  (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)))
-           (and (string=? (format #f "foo/~a/bar" two)
-                          (call-with-input-file (string-append graft "/text")
-                            get-string-all))
-                (string=? (readlink (string-append graft "/sh")) one)
-                (string=? (readlink (string-append graft "/self")) graft))))))
-
 (test-equal "map-derivation"
   "hello"
   (let* ((joke (package-derivation %store guile-1.8))

tests/grafts.scm

@@ -0,0 +1,81 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-grafts)
+  #:use-module (guix derivations)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (guix grafts)
+  #:use-module (guix tests)
+  #:use-module ((gnu packages) #:select (search-bootstrap-binary))
+  #:use-module (srfi srfi-64)
+  #:use-module (rnrs io ports))
+
+(define %store
+  (open-connection-for-tests))
+
+(define (bootstrap-binary name)
+  (let ((bin (search-bootstrap-binary name (%current-system))))
+    (and %store
+         (add-to-store %store name #t "sha256" bin))))
+
+(define %bash
+  (bootstrap-binary "bash"))
+(define %mkdir
+  (bootstrap-binary "mkdir"))
+
+
+(test-begin "grafts")
+
+(test-assert "graft-derivation"
+  (let* ((build `(begin
+                   (mkdir %output)
+                   (chdir %output)
+                   (symlink %output "self")
+                   (call-with-output-file "text"
+                     (lambda (output)
+                       (format output "foo/~a/bar" ,%mkdir)))
+                   (symlink ,%bash "sh")))
+         (orig  (build-expression->derivation %store "graft" build
+                                              #:inputs `(("a" ,%bash)
+                                                         ("b" ,%mkdir))))
+         (one   (add-text-to-store %store "bash" "fake bash"))
+         (two   (build-expression->derivation %store "mkdir"
+                                              '(call-with-output-file %output
+                                                 (lambda (port)
+                                                   (display "fake mkdir" port)))))
+         (graft (graft-derivation %store "graft" orig
+                                  (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)))
+           (and (string=? (format #f "foo/~a/bar" two)
+                          (call-with-input-file (string-append graft "/text")
+                            get-string-all))
+                (string=? (readlink (string-append graft "/sh")) one)
+                (string=? (readlink (string-append graft "/self")) graft))))))
+
+(test-end)
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))

tests/packages.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +29,7 @@
   #:use-module (guix hash)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix grafts)
   #:use-module (guix search-paths)
   #:use-module (guix build-system)
   #:use-module (guix build-system trivial)