futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

hydra: Honor 'package-supported-systems'.

Browse Source 
* guix/packages.scm (%supported-systems): New variable.
  (<package>)[platforms]: Rename to...
  [supported-systems]: ... this.  Change default to %SUPPORTED-SYSTEMS.
* build-aux/hydra/gnu-system.scm (job-name, package->job): New
  procedures, formerly in 'hydra-jobs'.  Honor 'package-supported-systems'.
  (hydra-jobs): Use them.
This commit is contained in:
Ludovic Courtès 2014-10-06 19:14:47 +02:00
parent 288dca55a8
commit 4e097f8606
2 changed files with 60 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
build-aux/hydra/gnu-system.scm
View File

@ -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))

12
guix/packages.scm
View File

@ -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