package-patched-vulnerabilities
package-with-patches
package-with-extra-patches
+ package-with-c-toolchain
package/inherit
transitive-input-references
%supported-systems
%hurd-systems
- %hydra-supported-systems
+ %cuirass-supported-systems
supported-package?
&package-error
;;;
;;; Code:
+(define-syntax-rule (define-compile-time-decoder name string->bytevector)
+ "Define NAME as a macro that runs STRING->BYTEVECTOR at macro expansion time
+if possible."
+ (define-syntax name
+ (lambda (s)
+ "Return the bytevector corresponding to the given textual
+representation."
+ (syntax-case s ()
+ ((_ str)
+ (string? (syntax->datum #'str))
+ ;; A literal string: do the conversion at expansion time.
+ (with-syntax ((bv (string->bytevector (syntax->datum #'str))))
+ #''bv))
+ ((_ str)
+ #'(string->bytevector str))))))
+
+(define-compile-time-decoder base32 nix-base32-string->bytevector)
+(define-compile-time-decoder base64 base64-decode)
+
;; Crytographic content hash.
(define-immutable-record-type <content-hash>
(%content-hash algorithm value)
(set-record-type-printer! <origin> print-origin)
-(define-syntax-rule (define-compile-time-decoder name string->bytevector)
- "Define NAME as a macro that runs STRING->BYTEVECTOR at macro expansion time
-if possible."
- (define-syntax name
- (lambda (s)
- "Return the bytevector corresponding to the given textual
-representation."
- (syntax-case s ()
- ((_ str)
- (string? (syntax->datum #'str))
- ;; A literal string: do the conversion at expansion time.
- (with-syntax ((bv (string->bytevector (syntax->datum #'str))))
- #''bv))
- ((_ str)
- #'(string->bytevector str))))))
-
-(define-compile-time-decoder base32 nix-base32-string->bytevector)
-(define-compile-time-decoder base64 base64-decode)
-
(define (origin-actual-file-name origin)
"Return the file name of ORIGIN, either its 'file-name' field or the file
name of its URI."
;; The GNU/Hurd systems for which support is being developed.
'("i586-gnu" "i686-gnu"))
-(define %hydra-supported-systems
+(define %cuirass-supported-systems
;; This is the list of system types for which build machines are available.
;;
;; XXX: MIPS is unavailable in CI:
(define-syntax-rule (package/inherit p overrides ...)
"Like (package (inherit P) OVERRIDES ...), except that the same
-transformation is done to the package replacement, if any. P must be a bare
+transformation is done to the package P's replacement, if any. P must be a bare
identifier, and will be bound to either P or its replacement when evaluating
OVERRIDES."
(let loop ((p p))
(match (package-location package)
(($ <location> file line column)
- (catch 'system-error
- (lambda ()
- ;; In general we want to keep relative file names for modules.
- (call-with-input-file (search-path %load-path file)
- (lambda (port)
- (goto port line column)
- (match (read port)
- (('package inits ...)
- (let ((field (assoc field inits)))
- (match field
- ((_ value)
- (let ((loc (and=> (source-properties value)
- source-properties->location)))
- (and loc
- ;; Preserve the original file name, which may be a
- ;; relative file name.
- (set-field loc (location-file) file))))
- (_
- #f))))
- (_
- #f)))))
- (lambda _
- #f)))
+ (match (search-path %load-path file)
+ ((? string? file-found)
+ (catch 'system-error
+ (lambda ()
+ ;; In general we want to keep relative file names for modules.
+ (call-with-input-file file-found
+ (lambda (port)
+ (goto port line column)
+ (match (read port)
+ (('package inits ...)
+ (let ((field (assoc field inits)))
+ (match field
+ ((_ value)
+ (let ((loc (and=> (source-properties value)
+ source-properties->location)))
+ (and loc
+ ;; Preserve the original file name, which may be a
+ ;; relative file name.
+ (set-field loc (location-file) file))))
+ (_
+ #f))))
+ (_
+ #f)))))
+ (lambda _
+ #f)))
+ (#f
+ ;; FILE could not be found in %LOAD-PATH.
+ #f)))
(_ #f)))
(append (origin-patches (package-source original))
patches)))
+(define (package-with-c-toolchain package toolchain)
+ "Return a variant of PACKAGE that uses TOOLCHAIN instead of the default GNU
+C/C++ toolchain. TOOLCHAIN must be a list of inputs (label/package tuples)
+providing equivalent functionality, such as the 'gcc-toolchain' package."
+ (let ((bs (package-build-system package)))
+ (package/inherit package
+ (build-system (build-system-with-c-toolchain bs toolchain)))))
+
(define (transitive-inputs inputs)
"Return the closure of INPUTS when considering the 'propagated-inputs'
edges. Omit duplicate inputs, except for those already present in INPUTS
(define (rewrite input)
(match input
((label (? package? package) outputs ...)
- (let ((proc (if (cut? package) proc replace)))
- (cons* label (proc package) outputs)))
+ (cons* label (replace package) outputs))
(_
input)))
(define replace
(mlambdaq (p)
;; If P is the result of a previous call, return it.
- (if (assq-ref (package-properties p) mapping-property)
- p
-
- ;; Return a variant of P with PROC applied to P and its explicit
- ;; dependencies, recursively. Memoize the transformations. Failing
- ;; to do that, we would build a huge object graph with lots of
- ;; duplicates, which in turns prevents us from benefiting from
- ;; memoization in 'package-derivation'.
- (let ((p (proc p)))
- (package
- (inherit p)
- (location (package-location p))
- (build-system (if deep?
- (build-system-with-package-mapping
- (package-build-system p) rewrite)
- (package-build-system p)))
- (inputs (map rewrite (package-inputs p)))
- (native-inputs (map rewrite (package-native-inputs p)))
- (propagated-inputs (map rewrite (package-propagated-inputs p)))
- (replacement (and=> (package-replacement p) replace))
- (properties `((,mapping-property . #t)
- ,@(package-properties p))))))))
+ (cond ((assq-ref (package-properties p) mapping-property)
+ p)
+
+ ((cut? p)
+ ;; Since P's propagated inputs are really inputs of its dependents,
+ ;; rewrite them as well, unless we're doing a "shallow" rewrite.
+ (let ((p (proc p)))
+ (if (or (not deep?)
+ (null? (package-propagated-inputs p)))
+ p
+ (package
+ (inherit p)
+ (location (package-location p))
+ (replacement (package-replacement p))
+ (propagated-inputs (map rewrite (package-propagated-inputs p)))
+ (properties `((,mapping-property . #t)
+ ,@(package-properties p)))))))
+
+ (else
+ ;; Return a variant of P with PROC applied to P and its explicit
+ ;; dependencies, recursively. Memoize the transformations. Failing
+ ;; to do that, we would build a huge object graph with lots of
+ ;; duplicates, which in turns prevents us from benefiting from
+ ;; memoization in 'package-derivation'.
+ (let ((p (proc p)))
+ (package
+ (inherit p)
+ (location (package-location p))
+ (build-system (if deep?
+ (build-system-with-package-mapping
+ (package-build-system p) rewrite)
+ (package-build-system p)))
+ (inputs (map rewrite (package-inputs p)))
+ (native-inputs (map rewrite (package-native-inputs p)))
+ (propagated-inputs (map rewrite (package-propagated-inputs p)))
+ (replacement (and=> (package-replacement p) replace))
+ (properties `((,mapping-property . #t)
+ ,@(package-properties p)))))))))
replace)
(define* (package-input-rewriting replacements
- #:optional (rewrite-name identity))
+ #:optional (rewrite-name identity)
+ #:key (deep? #t))
"Return a procedure that, when passed a package, replaces its direct and
-indirect dependencies (but not its implicit inputs) according to REPLACEMENTS.
-REPLACEMENTS is a list of package pairs; the first element of each pair is the
-package to replace, and the second one is the replacement.
+indirect dependencies, including implicit inputs when DEEP? is true, according
+to REPLACEMENTS. REPLACEMENTS is a list of package pairs; the first element
+of each pair is the package to replace, and the second one is the replacement.
Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
package and returns its new name after rewrite."
+ (define replacement-property
+ ;; Property to tag right-hand sides in REPLACEMENTS.
+ (gensym " package-replacement"))
+
(define (rewrite p)
- (match (assq-ref replacements p)
- (#f (package
- (inherit p)
- (name (rewrite-name (package-name p)))))
- (new new)))
+ (if (assq-ref (package-properties p) replacement-property)
+ p
+ (match (assq-ref replacements p)
+ (#f (package/inherit p
+ (name (rewrite-name (package-name p)))))
+ (new (if deep?
+ (package/inherit new
+ (properties `((,replacement-property . #t)
+ ,@(package-properties new))))
+ new)))))
+
+ (define (cut? p)
+ (or (assq-ref (package-properties p) replacement-property)
+ (assq-ref replacements p)))
- (package-mapping rewrite (cut assq <> replacements)))
+ (package-mapping rewrite cut?
+ #:deep? deep?))
(define* (package-input-rewriting/spec replacements #:key (deep? #t))
"Return a procedure that, given a package, applies the given REPLACEMENTS to
HCoop / jackhill / guix / guix.git / blobdiff