packages: Implement grafts.

Thanks to Mark H. Weaver <mhw@netris.org> for insightful discussions
and suggestions.

* guix/packages.scm (<package>)[graft]: New field.
  (patch-and-repack): Invoke 'package-derivation' with #:graft? #f.
  (package-source-derivation): Likewise.  Do not use (%guile-for-build)
  in call to 'patch-and-repack', and we could end up using a grafted
  Guile.
  (expand-input): Likewise, also for 'package-cross-derivation' call.
  (package->bag): Add #:graft? parameter.  Honor it.  Use 'strip-append'
  instead of 'package-full-name'.
  (input-graft, input-cross-graft, bag-grafts, package-grafts): New
  procedures.
  (package-derivation, package-cross-derivation): Add #:graft? parameter
  and honor it.
* gnu/packages/bootstrap.scm (package-with-bootstrap-guile): Add
  recursive call on 'graft'.
* guix/build-system/gnu.scm (package-with-explicit-inputs,
  package-with-extra-configure-variable, static-package): Likewise.
  (gnu-build): Use the ungrafted Guile to avoid full rebuilds.
  (gnu-cross-build): Likewise.
* guix/build-system/cmake.scm (cmake-build): Likewise.
* guix/build-system/glib-or-gtk.scm (glib-or-gtk-build): Likewise.
* guix/build-system/perl.scm (perl-build): Likewise.
* guix/build-system/python.scm (python-build): Likewise.
* guix/build-system/ruby.scm (ruby-build): Likewise.
* guix/build-system/trivial.scm (guile-for-build): Likewise.
* tests/packages.scm ("package-derivation, direct graft",
  "package-cross-derivation, direct graft", "package-grafts,
  indirect grafts", "package-grafts, indirect grafts, cross",
  "package-grafts, indirect grafts, propagated inputs",
  "package-derivation, indirect grafts"): New tests.
  ("bag->derivation", "bag->derivation, cross-compilation"): Wrap in
  'parameterize'.
* doc/guix.texi (Security Updates): New node.
  (Invoking guix build): Document --no-graft.

1 files changed, 91 insertions, 14 deletions

diff --git a/tests/packages.scm b/tests/packages.scm
index 44cdb35c4b..4f700b712f 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -33,8 +33,9 @@
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages)
   #:use-module (gnu packages base)
+  #:use-module (gnu packages guile)
   #:use-module (gnu packages bootstrap)
-  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-64)
@@ -47,10 +48,6 @@
 (define %store
   (open-connection-for-tests))
 
-
-
-(test-begin "packages")
-
 (define-syntax-rule (dummy-package name* extra-fields ...)
   (package (name name*) (version "0") (source #f)
            (build-system gnu-build-system)
@@ -58,6 +55,9 @@
            (home-page #f) (license #f)
            extra-fields ...))
 
+
+(test-begin "packages")
+
 (test-assert "printer with location"
   (string-match "^#<package foo-0 foo.scm:42 [[:xdigit:]]+>$"
                 (with-output-to-string
@@ -375,6 +375,80 @@
       (package-cross-derivation %store p "mips64el-linux-gnu")
       #f)))
 
+(test-equal "package-derivation, direct graft"
+  (package-derivation %store gnu-make)
+  (let ((p (package (inherit coreutils)
+             (replacement gnu-make))))
+    (package-derivation %store p)))
+
+(test-equal "package-cross-derivation, direct graft"
+  (package-cross-derivation %store gnu-make "mips64el-linux-gnu")
+  (let ((p (package (inherit coreutils)
+             (replacement gnu-make))))
+    (package-cross-derivation %store p "mips64el-linux-gnu")))
+
+(test-assert "package-grafts, indirect grafts"
+  (let* ((new   (dummy-package "dep"
+                  (arguments '(#:implicit-inputs? #f))))
+         (dep   (package (inherit new) (version "0.0")))
+         (dep*  (package (inherit dep) (replacement new)))
+         (dummy (dummy-package "dummy"
+                  (arguments '(#:implicit-inputs? #f))
+                  (inputs `(("dep" ,dep*))))))
+    (equal? (package-grafts %store dummy)
+            (list (graft
+                    (origin (package-derivation %store dep))
+                    (replacement (package-derivation %store new)))))))
+
+(test-assert "package-grafts, indirect grafts, cross"
+  (let* ((new    (dummy-package "dep"
+                   (arguments '(#:implicit-inputs? #f))))
+         (dep    (package (inherit new) (version "0.0")))
+         (dep*   (package (inherit dep) (replacement new)))
+         (dummy  (dummy-package "dummy"
+                   (arguments '(#:implicit-inputs? #f))
+                   (inputs `(("dep" ,dep*)))))
+         (target "mips64el-linux-gnu"))
+    (equal? (package-grafts %store dummy #:target target)
+            (list (graft
+                    (origin (package-cross-derivation %store dep target))
+                    (replacement
+                     (package-cross-derivation %store new target)))))))
+
+(test-assert "package-grafts, indirect grafts, propagated inputs"
+  (let* ((new   (dummy-package "dep"
+                  (arguments '(#:implicit-inputs? #f))))
+         (dep   (package (inherit new) (version "0.0")))
+         (dep*  (package (inherit dep) (replacement new)))
+         (prop  (dummy-package "propagated"
+                  (propagated-inputs `(("dep" ,dep*)))
+                  (arguments '(#:implicit-inputs? #f))))
+         (dummy (dummy-package "dummy"
+                  (arguments '(#:implicit-inputs? #f))
+                  (inputs `(("prop" ,prop))))))
+    (equal? (package-grafts %store dummy)
+            (list (graft
+                    (origin (package-derivation %store dep))
+                    (replacement (package-derivation %store new)))))))
+
+(test-assert "package-derivation, indirect grafts"
+  (let* ((new   (dummy-package "dep"
+                  (arguments '(#:implicit-inputs? #f))))
+         (dep   (package (inherit new) (version "0.0")))
+         (dep*  (package (inherit dep) (replacement new)))
+         (dummy (dummy-package "dummy"
+                  (arguments '(#:implicit-inputs? #f))
+                  (inputs `(("dep" ,dep*)))))
+         (guile (package-derivation %store (canonical-package guile-2.0)
+                                    #:graft? #f)))
+    (equal? (package-derivation %store dummy)
+            (graft-derivation %store "dummy-0"
+                              (package-derivation %store dummy #:graft? #f)
+                              (package-grafts %store dummy)
+
+                              ;; Use the same Guile as 'package-derivation'.
+                              #:guile guile))))
+
 (test-equal "package->bag"
   `("foo86-hurd" #f (,(package-source gnu-make))
     (,(canonical-package glibc)) (,(canonical-package coreutils)))
@@ -406,17 +480,20 @@
        (eq? package dep)))))
 
 (test-assert "bag->derivation"
-  (let ((bag (package->bag gnu-make))
-        (drv (package-derivation %store gnu-make)))
-    (parameterize ((%current-system "foox86-hurd")) ;should have no effect
-      (equal? drv (bag->derivation %store bag)))))
+  (parameterize ((%graft? #f))
+    (let ((bag (package->bag gnu-make))
+          (drv (package-derivation %store gnu-make)))
+      (parameterize ((%current-system "foox86-hurd")) ;should have no effect
+        (equal? drv (bag->derivation %store bag))))))
 
 (test-assert "bag->derivation, cross-compilation"
-  (let ((bag (package->bag gnu-make (%current-system) "mips64el-linux-gnu"))
-        (drv (package-cross-derivation %store gnu-make "mips64el-linux-gnu")))
-    (parameterize ((%current-system "foox86-hurd") ;should have no effect
-                   (%current-target-system "foo64-linux-gnu"))
-      (equal? drv (bag->derivation %store bag)))))
+  (parameterize ((%graft? #f))
+    (let* ((target "mips64el-linux-gnu")
+           (bag    (package->bag gnu-make (%current-system) target))
+           (drv    (package-cross-derivation %store gnu-make target)))
+      (parameterize ((%current-system "foox86-hurd") ;should have no effect
+                     (%current-target-system "foo64-linux-gnu"))
+        (equal? drv (bag->derivation %store bag))))))
 
 (unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))
   (test-skip 1))