diff options
| -rw-r--r-- | build-aux/hydra/gnu-system.scm | 88 | ||||
| -rw-r--r-- | guix/packages.scm | 12 |
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 |