aboutsummaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/cmake.scm4
-rw-r--r--guix/build-system/glib-or-gtk.scm4
-rw-r--r--guix/build-system/gnu.scm30
-rw-r--r--guix/build-system/perl.scm4
-rw-r--r--guix/build-system/python.scm4
-rw-r--r--guix/build-system/ruby.scm4
-rw-r--r--guix/build-system/trivial.scm4
-rw-r--r--guix/packages.scm147
-rw-r--r--guix/scripts/build.scm47
9 files changed, 190 insertions, 58 deletions
diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm
index 85acc2d0b3..0425e9fb39 100644
--- a/guix/build-system/cmake.scm
+++ b/guix/build-system/cmake.scm
@@ -125,11 +125,11 @@ provides a 'CMakeLists.txt' file as its build system."
(define guile-for-build
(match guile
((? package?)
- (package-derivation store guile system))
+ (package-derivation store guile system #:graft? #f))
(#f ; the default
(let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final)))
- (package-derivation store guile system)))))
+ (package-derivation store guile system #:graft? #f)))))
(build-expression->derivation store name builder
#:system system
diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm
index 078d5f6e8a..51e0c419e3 100644
--- a/guix/build-system/glib-or-gtk.scm
+++ b/guix/build-system/glib-or-gtk.scm
@@ -168,11 +168,11 @@
(define guile-for-build
(match guile
((? package?)
- (package-derivation store guile system))
+ (package-derivation store guile system #:graft? #f))
(#f ; the default
(let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final)))
- (package-derivation store guile system)))))
+ (package-derivation store guile system #:graft? #f)))))
(build-expression->derivation store name builder
#:system system
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index 3cb9f6ae94..c675155a6a 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -91,6 +91,13 @@ builder, or the distro's final Guile when GUILE is #f."
`(#:guile ,guile
#:implicit-inputs? #f
,@args)))
+ (replacement
+ (let ((replacement (package-replacement p)))
+ (and replacement
+ (package-with-explicit-inputs replacement inputs loc
+ #:native-inputs
+ native-inputs
+ #:guile guile))))
(native-inputs
(let ((filtered (duplicate-filter native-inputs*)))
`(,@(call native-inputs*)
@@ -132,6 +139,11 @@ flags for VARIABLE, the associated value is augmented."
(substring flag ,len))
flag))
,flags)))))))
+ (replacement
+ (let ((replacement (package-replacement p)))
+ (and replacement
+ (package-with-extra-configure-variable replacement
+ variable value))))
(inputs (rewritten-inputs (package-inputs p)))
(propagated-inputs (rewritten-inputs (package-propagated-inputs p))))))
@@ -155,7 +167,8 @@ use `--strip-all' as the arguments to `strip'."
((#:strip-flags flags)
(if strip-all?
''("--strip-all")
- flags)))))))
+ flags)))))
+ (replacement (and=> (package-replacement p) static-package))))
(define* (dist-package p source)
"Return a package that runs takes source files from the SOURCE directory,
@@ -290,9 +303,11 @@ are allowed to refer to."
(define canonicalize-reference
(match-lambda
((? package? p)
- (derivation->output-path (package-derivation store p system)))
+ (derivation->output-path (package-derivation store p system
+ #:graft? #f)))
(((? package? p) output)
- (derivation->output-path (package-derivation store p system)
+ (derivation->output-path (package-derivation store p system
+ #:graft? #f)
output))
((? string? output)
output)))
@@ -328,11 +343,12 @@ are allowed to refer to."
(define guile-for-build
(match guile
((? package?)
- (package-derivation store guile system))
+ (package-derivation store guile system #:graft? #f))
(#f ; the default
(let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final)))
- (package-derivation store guile system)))))
+ (package-derivation store guile system
+ #:graft? #f)))))
(build-expression->derivation store name builder
#:system system
@@ -472,11 +488,11 @@ platform."
(define guile-for-build
(match guile
((? package?)
- (package-derivation store guile system))
+ (package-derivation store guile system #:graft? #f))
(#f ; the default
(let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final)))
- (package-derivation store guile system)))))
+ (package-derivation store guile system #:graft? #f)))))
(build-expression->derivation store name builder
#:system system
diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm
index 1a968f4150..c488adb500 100644
--- a/guix/build-system/perl.scm
+++ b/guix/build-system/perl.scm
@@ -114,11 +114,11 @@ provides a `Makefile.PL' file as its build system."
(define guile-for-build
(match guile
((? package?)
- (package-derivation store guile system))
+ (package-derivation store guile system #:graft? #f))
(#f ; the default
(let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final)))
- (package-derivation store guile system)))))
+ (package-derivation store guile system #:graft? #f)))))
(build-expression->derivation store name builder
#:system system
diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm
index 3cd537c752..78348e9cf7 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -160,11 +160,11 @@ provides a 'setup.py' file as its build system."
(define guile-for-build
(match guile
((? package?)
- (package-derivation store guile system))
+ (package-derivation store guile system #:graft? #f))
(#f ; the default
(let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final)))
- (package-derivation store guile system)))))
+ (package-derivation store guile system #:graft? #f)))))
(build-expression->derivation store name builder
#:inputs inputs
diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm
index e4e115f657..d2dd6a48cc 100644
--- a/guix/build-system/ruby.scm
+++ b/guix/build-system/ruby.scm
@@ -99,11 +99,11 @@
(define guile-for-build
(match guile
((? package?)
- (package-derivation store guile system))
+ (package-derivation store guile system #:graft? #f))
(#f
(let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final)))
- (package-derivation store guile system)))))
+ (package-derivation store guile system #:graft? #f)))))
(build-expression->derivation store name builder
#:inputs inputs
diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm
index 07adbe75fa..350b1df553 100644
--- a/guix/build-system/trivial.scm
+++ b/guix/build-system/trivial.scm
@@ -28,11 +28,11 @@
(define (guile-for-build store guile system)
(match guile
((? package?)
- (package-derivation store guile system))
+ (package-derivation store guile system #:graft? #f))
(#f ; the default
(let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final)))
- (package-derivation store guile system)))))
+ (package-derivation store guile system #:graft? #f)))))
(define* (lower name
#:key source inputs native-inputs outputs system target
diff --git a/guix/packages.scm b/guix/packages.scm
index 97a82a4682..698a4c8097 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -26,6 +26,7 @@
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
@@ -65,6 +66,7 @@
package-outputs
package-native-search-paths
package-search-paths
+ package-replacement
package-synopsis
package-description
package-license
@@ -85,6 +87,7 @@
package-derivation
package-cross-derivation
package-output
+ package-grafts
%supported-systems
@@ -97,6 +100,7 @@
&package-cross-build-system-error
package-cross-build-system-error?
+ %graft?
package->bag
bag->derivation
bag-transitive-inputs
@@ -211,6 +215,8 @@ corresponds to the arguments expected by `set-path-environment-variable'."
; inputs
(native-search-paths package-native-search-paths (default '()))
(search-paths package-search-paths (default '()))
+ (replacement package-replacement ; package | #f
+ (default #f) (thunked))
(synopsis package-synopsis) ; one-line description
(description package-description) ; one or two paragraphs
@@ -445,8 +451,8 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
(and (member name (cons decompression-type
'("tar" "xz" "patch")))
(list name
- (package-derivation store p
- system)))))
+ (package-derivation store p system
+ #:graft? #f)))))
(or inputs (%standard-patch-inputs))))
(modules (delete-duplicates (cons '(guix build utils) modules))))
@@ -472,12 +478,10 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
;; Patches and/or a snippet.
(let ((source (method store uri 'sha256 sha256 name
#:system system))
- (guile (match (or guile-for-build (%guile-for-build)
- (default-guile))
+ (guile (match (or guile-for-build (default-guile))
((? package? p)
- (package-derivation store p system))
- ((? derivation? drv)
- drv))))
+ (package-derivation store p system
+ #:graft? #f)))))
(patch-and-repack store source patches
#:inputs inputs
#:snippet snippet
@@ -617,8 +621,9 @@ information in exceptions."
(define derivation
(if cross-system
- (cut package-cross-derivation store <> cross-system system)
- (cut package-derivation store <> system)))
+ (cut package-cross-derivation store <> cross-system system
+ #:graft? #f)
+ (cut package-derivation store <> system #:graft? #f)))
(match input
(((? string? name) (? package? package))
@@ -643,20 +648,27 @@ information in exceptions."
(package package)
(input x)))))))
+(define %graft?
+ ;; Whether to honor package grafts by default.
+ (make-parameter #t))
+
(define* (package->bag package #:optional
(system (%current-system))
- (target (%current-target-system)))
+ (target (%current-target-system))
+ #:key (graft? (%graft?)))
"Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
and return it."
;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked field
;; values can refer to it.
(parameterize ((%current-system system)
(%current-target-system target))
- (match package
+ (match (if graft?
+ (or (package-replacement package) package)
+ package)
(($ <package> name version source build-system
args inputs propagated-inputs native-inputs self-native-input?
outputs)
- (or (make-bag build-system (package-full-name package)
+ (or (make-bag build-system (string-append name "-" version)
#:system system
#:target target
#:source source
@@ -676,6 +688,77 @@ and return it."
(&package-error
(package package))))))))))
+(define (input-graft store system)
+ "Return a procedure that, given an input referring to a package with a
+graft, returns a pair with the original derivation and the graft's derivation,
+and returns #f for other inputs."
+ (match-lambda
+ ((label (? package? package) sub-drv ...)
+ (let ((replacement (package-replacement package)))
+ (and replacement
+ (let ((orig (package-derivation store package system
+ #:graft? #f))
+ (new (package-derivation store replacement system)))
+ (graft
+ (origin orig)
+ (replacement new)
+ (origin-output (match sub-drv
+ (() "out")
+ ((output) output)))
+ (replacement-output origin-output))))))
+ (x
+ #f)))
+
+(define (input-cross-graft store target system)
+ "Same as 'input-graft', but for cross-compilation inputs."
+ (match-lambda
+ ((label (? package? package) sub-drv ...)
+ (let ((replacement (package-replacement package)))
+ (and replacement
+ (let ((orig (package-cross-derivation store package target system
+ #:graft? #f))
+ (new (package-cross-derivation store replacement
+ target system)))
+ (graft
+ (origin orig)
+ (replacement new)
+ (origin-output (match sub-drv
+ (() "out")
+ ((output) output)))
+ (replacement-output origin-output))))))
+ (_
+ #f)))
+
+(define* (bag-grafts store bag)
+ "Return the list of grafts applicable to BAG. Each graft is a <graft>
+record."
+ (let ((target (bag-target bag))
+ (system (bag-system bag)))
+ (define native-grafts
+ (filter-map (input-graft store system)
+ (append (bag-transitive-build-inputs bag)
+ (bag-transitive-target-inputs bag)
+ (if target
+ '()
+ (bag-transitive-host-inputs bag)))))
+
+ (define target-grafts
+ (if target
+ (filter-map (input-cross-graft store target system)
+ (bag-transitive-host-inputs bag))
+ '()))
+
+ (append native-grafts target-grafts)))
+
+(define* (package-grafts store package
+ #:optional (system (%current-system))
+ #:key target)
+ "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
+TARGET."
+ (let* ((package (or (package-replacement package) package))
+ (bag (package->bag package system target)))
+ (bag-grafts store bag)))
+
(define* (bag->derivation store bag
#:optional context)
"Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
@@ -743,23 +826,47 @@ This is an internal procedure."
(bag-arguments bag))))
(define* (package-derivation store package
- #:optional (system (%current-system)))
+ #:optional (system (%current-system))
+ #:key (graft? (%graft?)))
"Return the <derivation> object of PACKAGE for SYSTEM."
;; Compute the derivation and cache the result. Caching is important
;; because some derivations, such as the implicit inputs of the GNU build
;; system, will be queried many, many times in a row.
- (cached package system
- (bag->derivation store (package->bag package system #f)
- package)))
+ (cached package (cons system graft?)
+ (let* ((bag (package->bag package system #f #:graft? graft?))
+ (drv (bag->derivation store bag package)))
+ (if graft?
+ (match (bag-grafts store bag)
+ (()
+ drv)
+ (grafts
+ (let ((guile (package-derivation store (default-guile)
+ system #:graft? #f)))
+ (graft-derivation store (bag-name bag) drv grafts
+ #:system system
+ #:guile guile))))
+ drv))))
(define* (package-cross-derivation store package target
- #:optional (system (%current-system)))
+ #:optional (system (%current-system))
+ #:key (graft? (%graft?)))
"Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
system identifying string)."
- (cached package (cons system target)
- (bag->derivation store (package->bag package system target)
- package)))
+ (cached package (list system target graft?)
+ (let* ((bag (package->bag package system target #:graft? graft?))
+ (drv (bag->derivation store bag package)))
+ (if graft?
+ (match (bag-grafts store bag)
+ (()
+ drv)
+ (grafts
+ (graft-derivation store (bag-name bag) drv grafts
+ #:system system
+ #:guile
+ (package-derivation store (default-guile)
+ system #:graft? #f))))
+ drv))))
(define* (package-output store package
#:optional (output "out") (system (%current-system)))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index cde2a25613..7b7f419f3a 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -202,6 +202,7 @@ options handled by 'set-build-options-from-command-line', and listed in
(define %default-options
;; Alist of default option values.
`((system . ,(%current-system))
+ (graft? . #t)
(substitutes? . #t)
(build-hook? . #t)
(print-build-trace? . #t)
@@ -223,6 +224,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
--with-source=SOURCE
use SOURCE when building the corresponding package"))
(display (_ "
+ --no-grafts do not graft packages"))
+ (display (_ "
-d, --derivations return the derivation paths of the given packages"))
(display (_ "
-r, --root=FILE make FILE a symlink to the result, and register it
@@ -278,6 +281,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(option '("with-source") #t #f
(lambda (opt name arg result)
(alist-cons 'with-source arg result)))
+ (option '("no-grafts") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'graft? #f
+ (alist-delete 'graft? result eq?))))
%standard-build-options))
@@ -290,26 +297,28 @@ build."
(triplet
(cut package-cross-derivation <> <> triplet <>))))
- (define src? (assoc-ref opts 'source?))
- (define sys (assoc-ref opts 'system))
+ (define src? (assoc-ref opts 'source?))
+ (define sys (assoc-ref opts 'system))
+ (define graft? (assoc-ref opts 'graft?))
- (let ((opts (options/with-source store
- (options/resolve-packages store opts))))
- (filter-map (match-lambda
- (('argument . (? package? p))
- (if src?
- (let ((s (package-source p)))
- (package-source-derivation store s))
- (package->derivation store p sys)))
- (('argument . (? derivation? drv))
- drv)
- (('argument . (? derivation-path? drv))
- (call-with-input-file drv read-derivation))
- (('argument . (? store-path?))
- ;; Nothing to do; maybe for --log-file.
- #f)
- (_ #f))
- opts)))
+ (parameterize ((%graft? graft?))
+ (let ((opts (options/with-source store
+ (options/resolve-packages store opts))))
+ (filter-map (match-lambda
+ (('argument . (? package? p))
+ (if src?
+ (let ((s (package-source p)))
+ (package-source-derivation store s))
+ (package->derivation store p sys)))
+ (('argument . (? derivation? drv))
+ drv)
+ (('argument . (? derivation-path? drv))
+ (call-with-input-file drv read-derivation))
+ (('argument . (? store-path?))
+ ;; Nothing to do; maybe for --log-file.
+ #f)
+ (_ #f))
+ opts))))
(define (options/resolve-packages store opts)
"Return OPTS with package specification strings replaced by actual
generated by cgit v1.2.3 (git 2.45.0) at 2025-02-06 10:14:58 +0000