From 91c9b5d016ac8bed127557d378c70fbc56cec0e5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 5 Dec 2017 16:32:40 +0100
Subject: [PATCH] packages: 'package-grafts' trims native inputs.

'package-grafts' returns a list of potentially applicable grafts, which
'cumulative-grafts' then narrows by looking at store item references and
determining the subset of the grafts that's actually applicable.

Until now, 'package-grafts' would traverse native inputs and would thus
return a large superset of the applicable grafts, since native inputs
are not in the reference graph by definition.  This patch fixes that by
having 'package-grafts' ignore entirely native inputs from the
dependency graph.

* guix/packages.scm (fold-bag-dependencies)[bag-direct-inputs*]: Add
special case for libc.
* guix/packages.scm (bag-grafts)[native-grafts, target-grafts]: Remove.
[grafts]: New procedure.
Use it.
* tests/packages.scm ("package-grafts, grafts of native inputs
ignored"): New test.
---
 guix/packages.scm  | 51 +++++++++++++++++++++++++++-------------------
 tests/packages.scm | 18 ++++++++++++++++
 2 files changed, 48 insertions(+), 21 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index c6d3b811f2..490ec86906 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1004,7 +1004,21 @@ dependencies; otherwise, restrict to target dependencies."
                   (if (bag-target bag)
                       '()
                       (bag-host-inputs bag))))
-        bag-host-inputs))
+        (lambda (bag)
+          (if (bag-target bag)
+              (bag-host-inputs bag)
+
+              ;; XXX: Currently libc wrongfully ends up in 'build-inputs',
+              ;; even tough it's something that's still referenced at run time
+              ;; and thus conceptually a 'host-inputs'.  Because of that, we
+              ;; re-add it here.
+              (if (assoc-ref (bag-host-inputs bag) "libc")
+                  (bag-host-inputs bag)
+                  (append (let ((libc (assoc-ref (bag-build-inputs bag)
+                                                 "libc")))
+                            (or (and libc `(("libc" ,@libc)))
+                                '()))
+                          (bag-host-inputs bag)))))))
 
   (define nodes
     (match (bag-direct-inputs* bag)
@@ -1038,33 +1052,28 @@ to (see 'graft-derivation'.)"
   (define system (bag-system bag))
   (define target (bag-target bag))
 
-  (define native-grafts
-    (let ((->graft (input-graft store system)))
-      (fold-bag-dependencies (lambda (package grafts)
-                               (match (->graft package)
-                                 (#f    grafts)
-                                 (graft (cons graft grafts))))
-                             '()
-                             bag)))
+  (define (grafts package->graft)
+    (fold-bag-dependencies (lambda (package grafts)
+                             (match (package->graft package)
+                               (#f    grafts)
+                               (graft (cons graft grafts))))
+                           '()
+                           bag
 
-  (define target-grafts
-    (if target
-        (let ((->graft (input-cross-graft store target system)))
-          (fold-bag-dependencies (lambda (package grafts)
-                                   (match (->graft package)
-                                     (#f    grafts)
-                                     (graft (cons graft grafts))))
-                                 '()
-                                 bag
-                                 #:native? #f))
-        '()))
+                           ;; Grafts that apply to native inputs do not matter
+                           ;; since, by definition, native inputs are not
+                           ;; referred to at run time.  Thus, ignore
+                           ;; 'native-inputs' and focus on the others.
+                           #:native? #f))
 
   ;; We can end up with several identical grafts if we stumble upon packages
   ;; that are not 'eq?' but map to the same derivation (this can happen when
   ;; using things like 'package-with-explicit-inputs'.)  Hence the
   ;; 'delete-duplicates' call.
   (delete-duplicates
-   (append native-grafts target-grafts)))
+   (if target
+       (grafts (input-cross-graft store target system))
+       (grafts (input-graft store system)))))
 
 (define* (package-grafts store package
                          #:optional (system (%current-system))
diff --git a/tests/packages.scm b/tests/packages.scm
index 930374dabf..fe7bd1ded6 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -660,6 +660,24 @@
 ;;     (package-cross-derivation %store p "mips64el-linux-gnu"
 ;;                               #:graft? #t)))
 
+;; It doesn't make sense for 'package-grafts' to look at native inputs since,
+;; by definition, they are not referenced at run time.  Make sure
+;; 'package-grafts' respects this.
+(test-equal "package-grafts, grafts of native inputs ignored"
+  '()
+  (let* ((new   (dummy-package "native-dep"
+                  (version "0.1")
+                  (arguments '(#:implicit-inputs? #f))))
+         (ndep  (package (inherit new) (version "0.0")
+                         (replacement new)))
+         (dep   (dummy-package "dep"
+                  (arguments '(#:implicit-inputs? #f))))
+         (dummy (dummy-package "dummy"
+                  (arguments '(#:implicit-inputs? #f))
+                  (native-inputs `(("ndep" ,ndep)))
+                  (inputs `(("dep" ,dep))))))
+    (package-grafts %store dummy)))
+
 (test-assert "package-grafts, indirect grafts"
   (let* ((new   (dummy-package "dep"
                   (arguments '(#:implicit-inputs? #f))))