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.

1 files changed, 0 insertions, 98 deletions

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 5db739a97d..1164774009 100644
--- a/guix/derivations.scm
+++ b/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)))