;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2017, 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
+;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
%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."
(define %supported-systems
;; This is the list of system types that are supported. By default, we
;; expect all packages to build successfully here.
- '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux" "i586-gnu"))
+ '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux" "i586-gnu"
+ "powerpc64le-linux"))
(define %hurd-systems
;; 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)))
"Return package ORIGINAL with PATCHES applied."
(package (inherit original)
(source (origin (inherit (package-source original))
- (patches patches)))))
+ (patches patches)))
+ (location (package-location original))))
(define (package-with-extra-patches original patches)
"Return package ORIGINAL with all PATCHES appended to its list of patches."
(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)
HCoop / jackhill / guix / guix.git / blobdiff