diff options
| -rw-r--r-- | guix/packages.scm | 53 | ||||
| -rw-r--r-- | tests/packages.scm | 18 |
2 files changed, 22 insertions, 49 deletions
diff --git a/guix/packages.scm b/guix/packages.scm index 490ec869063..c6d3b811f21 100644 --- a/guix/packages.scm +++ b/guix/packages.scm | |||
| @@ -1004,21 +1004,7 @@ 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 | (lambda (bag) | 1007 | bag-host-inputs)) |
| 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))))))) | ||
| 1022 | 1008 | ||
| 1023 | (define nodes | 1009 | (define nodes |
| 1024 | (match (bag-direct-inputs* bag) | 1010 | (match (bag-direct-inputs* bag) |
| @@ -1052,28 +1038,33 @@ to (see 'graft-derivation'.)" | |||
| 1052 | (define system (bag-system bag)) | 1038 | (define system (bag-system bag)) |
| 1053 | (define target (bag-target bag)) | 1039 | (define target (bag-target bag)) |
| 1054 | 1040 | ||
| 1055 | (define (grafts package->graft) | 1041 | (define native-grafts |
| 1056 | (fold-bag-dependencies (lambda (package grafts) | 1042 | (let ((->graft (input-graft store system))) |
| 1057 | (match (package->graft package) | 1043 | (fold-bag-dependencies (lambda (package grafts) |
| 1058 | (#f grafts) | 1044 | (match (->graft package) |
| 1059 | (graft (cons graft grafts)))) | 1045 | (#f grafts) |
| 1060 | '() | 1046 | (graft (cons graft grafts)))) |
| 1061 | bag | 1047 | '() |
| 1062 | 1048 | bag))) | |
| 1063 | ;; Grafts that apply to native inputs do not matter | 1049 | |
| 1064 | ;; since, by definition, native inputs are not | 1050 | (define target-grafts |
| 1065 | ;; referred to at run time. Thus, ignore | 1051 | (if target |
| 1066 | ;; 'native-inputs' and focus on the others. | 1052 | (let ((->graft (input-cross-graft store target system))) |
| 1067 | #:native? #f)) | 1053 | (fold-bag-dependencies (lambda (package grafts) |
| 1054 | (match (->graft package) | ||
| 1055 | (#f grafts) | ||
| 1056 | (graft (cons graft grafts)))) | ||
| 1057 | '() | ||
| 1058 | bag | ||
| 1059 | #:native? #f)) | ||
| 1060 | '())) | ||
| 1068 | 1061 | ||
| 1069 | ;; We can end up with several identical grafts if we stumble upon packages | 1062 | ;; We can end up with several identical grafts if we stumble upon packages |
| 1070 | ;; that are not 'eq?' but map to the same derivation (this can happen when | 1063 | ;; that are not 'eq?' but map to the same derivation (this can happen when |
| 1071 | ;; using things like 'package-with-explicit-inputs'.) Hence the | 1064 | ;; using things like 'package-with-explicit-inputs'.) Hence the |
| 1072 | ;; 'delete-duplicates' call. | 1065 | ;; 'delete-duplicates' call. |
| 1073 | (delete-duplicates | 1066 | (delete-duplicates |
| 1074 | (if target | 1067 | (append native-grafts target-grafts))) |
| 1075 | (grafts (input-cross-graft store target system)) | ||
| 1076 | (grafts (input-graft store system))))) | ||
| 1077 | 1068 | ||
| 1078 | (define* (package-grafts store package | 1069 | (define* (package-grafts store package |
| 1079 | #:optional (system (%current-system)) | 1070 | #:optional (system (%current-system)) |
diff --git a/tests/packages.scm b/tests/packages.scm index fe7bd1ded69..930374dabfa 100644 --- a/tests/packages.scm +++ b/tests/packages.scm | |||
| @@ -660,24 +660,6 @@ | |||
| 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 | |||
| 681 | (test-assert "package-grafts, indirect grafts" | 663 | (test-assert "package-grafts, indirect grafts" |
| 682 | (let* ((new (dummy-package "dep" | 664 | (let* ((new (dummy-package "dep" |
| 683 | (arguments '(#:implicit-inputs? #f)))) | 665 | (arguments '(#:implicit-inputs? #f)))) |
