summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/packages.scm53
-rw-r--r--tests/packages.scm18
2 files changed, 49 insertions, 22 deletions
diff --git a/guix/packages.scm b/guix/packages.scm
index c6d3b811f21..490ec869063 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1004,7 +1004,21 @@ dependencies; otherwise, restrict to target dependencies."
1004 (if (bag-target bag) 1004 (if (bag-target bag)
1005 '() 1005 '()
1006 (bag-host-inputs bag)))) 1006 (bag-host-inputs bag))))
1007 bag-host-inputs)) 1007 (lambda (bag)
1008 (if (bag-target bag)
1009 (bag-host-inputs bag)
1010
1011 ;; XXX: Currently libc wrongfully ends up in 'build-inputs',
1012 ;; even tough it's something that's still referenced at run time
1013 ;; and thus conceptually a 'host-inputs'. Because of that, we
1014 ;; re-add it here.
1015 (if (assoc-ref (bag-host-inputs bag) "libc")
1016 (bag-host-inputs bag)
1017 (append (let ((libc (assoc-ref (bag-build-inputs bag)
1018 "libc")))
1019 (or (and libc `(("libc" ,@libc)))
1020 '()))
1021 (bag-host-inputs bag)))))))
1008 1022
1009 (define nodes 1023 (define nodes
1010 (match (bag-direct-inputs* bag) 1024 (match (bag-direct-inputs* bag)
@@ -1038,33 +1052,28 @@ to (see 'graft-derivation'.)"
1038 (define system (bag-system bag)) 1052 (define system (bag-system bag))
1039 (define target (bag-target bag)) 1053 (define target (bag-target bag))
1040 1054
1041 (define native-grafts 1055 (define (grafts package->graft)
1042 (let ((->graft (input-graft store system))) 1056 (fold-bag-dependencies (lambda (package grafts)
1043 (fold-bag-dependencies (lambda (package grafts) 1057 (match (package->graft package)
1044 (match (->graft package) 1058 (#f grafts)
1045 (#f grafts) 1059 (graft (cons graft grafts))))
1046 (graft (cons graft grafts)))) 1060 '()
1047 '() 1061 bag
1048 bag))) 1062
1049 1063 ;; Grafts that apply to native inputs do not matter
1050 (define target-grafts 1064 ;; since, by definition, native inputs are not
1051 (if target 1065 ;; referred to at run time. Thus, ignore
1052 (let ((->graft (input-cross-graft store target system))) 1066 ;; 'native-inputs' and focus on the others.
1053 (fold-bag-dependencies (lambda (package grafts) 1067 #:native? #f))
1054 (match (->graft package)
1055 (#f grafts)
1056 (graft (cons graft grafts))))
1057 '()
1058 bag
1059 #:native? #f))
1060 '()))
1061 1068
1062 ;; We can end up with several identical grafts if we stumble upon packages 1069 ;; We can end up with several identical grafts if we stumble upon packages
1063 ;; that are not 'eq?' but map to the same derivation (this can happen when 1070 ;; that are not 'eq?' but map to the same derivation (this can happen when
1064 ;; using things like 'package-with-explicit-inputs'.) Hence the 1071 ;; using things like 'package-with-explicit-inputs'.) Hence the
1065 ;; 'delete-duplicates' call. 1072 ;; 'delete-duplicates' call.
1066 (delete-duplicates 1073 (delete-duplicates
1067 (append native-grafts target-grafts))) 1074 (if target
1075 (grafts (input-cross-graft store target system))
1076 (grafts (input-graft store system)))))
1068 1077
1069(define* (package-grafts store package 1078(define* (package-grafts store package
1070 #:optional (system (%current-system)) 1079 #:optional (system (%current-system))
diff --git a/tests/packages.scm b/tests/packages.scm
index 930374dabfa..fe7bd1ded69 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -660,6 +660,24 @@
660;; (package-cross-derivation %store p "mips64el-linux-gnu" 660;; (package-cross-derivation %store p "mips64el-linux-gnu"
661;; #:graft? #t))) 661;; #:graft? #t)))
662 662
663;; It doesn't make sense for 'package-grafts' to look at native inputs since,
664;; by definition, they are not referenced at run time. Make sure
665;; 'package-grafts' respects this.
666(test-equal "package-grafts, grafts of native inputs ignored"
667 '()
668 (let* ((new (dummy-package "native-dep"
669 (version "0.1")
670 (arguments '(#:implicit-inputs? #f))))
671 (ndep (package (inherit new) (version "0.0")
672 (replacement new)))
673 (dep (dummy-package "dep"
674 (arguments '(#:implicit-inputs? #f))))
675 (dummy (dummy-package "dummy"
676 (arguments '(#:implicit-inputs? #f))
677 (native-inputs `(("ndep" ,ndep)))
678 (inputs `(("dep" ,dep))))))
679 (package-grafts %store dummy)))
680
663(test-assert "package-grafts, indirect grafts" 681(test-assert "package-grafts, indirect grafts"
664 (let* ((new (dummy-package "dep" 682 (let* ((new (dummy-package "dep"
665 (arguments '(#:implicit-inputs? #f)))) 683 (arguments '(#:implicit-inputs? #f))))