aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--build-aux/hydra/gnu-system.scm88
-rw-r--r--guix/packages.scm12
2 files changed, 60 insertions, 40 deletions
diff --git a/build-aux/hydra/gnu-system.scm b/build-aux/hydra/gnu-system.scm
index c24f4ab512..c26bcff6ae 100644
--- a/build-aux/hydra/gnu-system.scm
+++ b/build-aux/hydra/gnu-system.scm
@@ -154,21 +154,41 @@ system.")
(* 630 MiB)))))
'()))
+(define job-name
+ ;; Return the name of a package's job.
+ (compose string->symbol package-full-name))
+
+(define package->job
+ (let ((base-packages
+ (delete-duplicates
+ (append-map (match-lambda
+ ((_ package _ ...)
+ (match (package-transitive-inputs package)
+ (((_ inputs _ ...) ...)
+ inputs))))
+ %final-inputs))))
+ (lambda (store package system)
+ "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
+valid."
+ (cond ((member package base-packages)
+ #f)
+ ((member system (package-supported-systems package))
+ (package-job store (job-name package) package system))
+ (else
+ #f)))))
+
+
+;;;
+;;; Hydra entry point.
+;;;
+
(define (hydra-jobs store arguments)
"Return Hydra jobs."
- (define systems
- ;; Systems we want to build for.
- '("x86_64-linux" "i686-linux"
- "mips64el-linux"))
-
(define subset
(match (assoc-ref arguments 'subset)
("core" 'core) ; only build core packages
(_ 'all))) ; build everything
- (define job-name
- (compose string->symbol package-full-name))
-
(define (cross-jobs system)
(define (from-32-to-64? target)
;; Return true if SYSTEM is 32-bit and TARGET is 64-bit.
@@ -195,33 +215,25 @@ system.")
(remove (either from-32-to-64? same?) %cross-targets)))
;; Return one job for each package, except bootstrap packages.
- (let ((base-packages (delete-duplicates
- (append-map (match-lambda
- ((_ package _ ...)
- (match (package-transitive-inputs
- package)
- (((_ inputs _ ...) ...)
- inputs))))
- %final-inputs))))
- (append-map (lambda (system)
- (case subset
- ((all)
- ;; Build everything.
- (fold-packages (lambda (package result)
- (if (member package base-packages)
- result
- (cons (package-job store (job-name package)
- package system)
- result)))
- (append (qemu-jobs store system)
- (cross-jobs system))))
- ((core)
- ;; Build core packages only.
- (append (map (lambda (package)
- (package-job store (job-name package)
- package system))
- %core-packages)
- (cross-jobs system)))
- (else
- (error "unknown subset" subset))))
- systems)))
+ (append-map (lambda (system)
+ (case subset
+ ((all)
+ ;; Build everything.
+ (fold-packages (lambda (package result)
+ (let ((job (package->job store package
+ system)))
+ (if job
+ (cons job result)
+ result)))
+ (append (qemu-jobs store system)
+ (cross-jobs system))))
+ ((core)
+ ;; Build core packages only.
+ (append (map (lambda (package)
+ (package-job store (job-name package)
+ package system))
+ %core-packages)
+ (cross-jobs system)))
+ (else
+ (error "unknown subset" subset))))
+ %supported-systems))
diff --git a/guix/packages.scm b/guix/packages.scm
index a5b886a403..76e01f3f12 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -69,7 +69,7 @@
package-description
package-license
package-home-page
- package-platforms
+ package-supported-systems
package-maintainers
package-properties
package-location
@@ -85,6 +85,8 @@
package-cross-derivation
package-output
+ %supported-systems
+
&package-error
package-error?
package-error-package
@@ -173,6 +175,11 @@ corresponds to the arguments expected by `set-path-environment-variable'."
(($ <search-path-specification> variable directories separator)
`(,variable ,directories ,separator))))
+(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" "mips64el-linux"))
+
;; A package.
(define-record-type* <package>
package make-package
@@ -208,7 +215,8 @@ corresponds to the arguments expected by `set-path-environment-variable'."
(description package-description) ; one or two paragraphs
(license package-license)
(home-page package-home-page)
- (platforms package-platforms (default '()))
+ (supported-systems package-supported-systems ; list of strings
+ (default %supported-systems))
(maintainers package-maintainers (default '()))
(properties package-properties (default '())) ; alist for anything else