hydra: Honor 'package-supported-systems'.
* 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:
		
							parent
							
								
									288dca55a8
								
							
						
					
					
						commit
						4e097f8606
					
				
					 2 changed files with 60 additions and 40 deletions
				
			
		| 
						 | 
					@ -154,21 +154,41 @@ system.")
 | 
				
			||||||
                                        (* 630 MiB)))))
 | 
					                                        (* 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)
 | 
					(define (hydra-jobs store arguments)
 | 
				
			||||||
  "Return Hydra jobs."
 | 
					  "Return Hydra jobs."
 | 
				
			||||||
  (define systems
 | 
					 | 
				
			||||||
    ;; Systems we want to build for.
 | 
					 | 
				
			||||||
    '("x86_64-linux" "i686-linux"
 | 
					 | 
				
			||||||
      "mips64el-linux"))
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
  (define subset
 | 
					  (define subset
 | 
				
			||||||
    (match (assoc-ref arguments 'subset)
 | 
					    (match (assoc-ref arguments 'subset)
 | 
				
			||||||
      ("core" 'core)                              ; only build core packages
 | 
					      ("core" 'core)                              ; only build core packages
 | 
				
			||||||
      (_ 'all)))                                  ; build everything
 | 
					      (_ 'all)))                                  ; build everything
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  (define job-name
 | 
					 | 
				
			||||||
    (compose string->symbol package-full-name))
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
  (define (cross-jobs system)
 | 
					  (define (cross-jobs system)
 | 
				
			||||||
    (define (from-32-to-64? target)
 | 
					    (define (from-32-to-64? target)
 | 
				
			||||||
      ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit.
 | 
					      ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit.
 | 
				
			||||||
| 
						 | 
					@ -195,23 +215,15 @@ system.")
 | 
				
			||||||
                (remove (either from-32-to-64? same?) %cross-targets)))
 | 
					                (remove (either from-32-to-64? same?) %cross-targets)))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  ;; Return one job for each package, except bootstrap packages.
 | 
					  ;; 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)
 | 
					  (append-map (lambda (system)
 | 
				
			||||||
                (case subset
 | 
					                (case subset
 | 
				
			||||||
                  ((all)
 | 
					                  ((all)
 | 
				
			||||||
                   ;; Build everything.
 | 
					                   ;; Build everything.
 | 
				
			||||||
                   (fold-packages (lambda (package result)
 | 
					                   (fold-packages (lambda (package result)
 | 
				
			||||||
                                      (if (member package base-packages)
 | 
					                                    (let ((job (package->job store package
 | 
				
			||||||
                                          result
 | 
					                                                             system)))
 | 
				
			||||||
                                          (cons (package-job store (job-name package)
 | 
					                                      (if job
 | 
				
			||||||
                                                             package system)
 | 
					                                          (cons job result)
 | 
				
			||||||
                                          result)))
 | 
					                                          result)))
 | 
				
			||||||
                                  (append (qemu-jobs store system)
 | 
					                                  (append (qemu-jobs store system)
 | 
				
			||||||
                                          (cross-jobs system))))
 | 
					                                          (cross-jobs system))))
 | 
				
			||||||
| 
						 | 
					@ -224,4 +236,4 @@ system.")
 | 
				
			||||||
                           (cross-jobs system)))
 | 
					                           (cross-jobs system)))
 | 
				
			||||||
                  (else
 | 
					                  (else
 | 
				
			||||||
                   (error "unknown subset" subset))))
 | 
					                   (error "unknown subset" subset))))
 | 
				
			||||||
                systems)))
 | 
					              %supported-systems))
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -69,7 +69,7 @@
 | 
				
			||||||
            package-description
 | 
					            package-description
 | 
				
			||||||
            package-license
 | 
					            package-license
 | 
				
			||||||
            package-home-page
 | 
					            package-home-page
 | 
				
			||||||
            package-platforms
 | 
					            package-supported-systems
 | 
				
			||||||
            package-maintainers
 | 
					            package-maintainers
 | 
				
			||||||
            package-properties
 | 
					            package-properties
 | 
				
			||||||
            package-location
 | 
					            package-location
 | 
				
			||||||
| 
						 | 
					@ -85,6 +85,8 @@
 | 
				
			||||||
            package-cross-derivation
 | 
					            package-cross-derivation
 | 
				
			||||||
            package-output
 | 
					            package-output
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					            %supported-systems
 | 
				
			||||||
 | 
					
 | 
				
			||||||
            &package-error
 | 
					            &package-error
 | 
				
			||||||
            package-error?
 | 
					            package-error?
 | 
				
			||||||
            package-error-package
 | 
					            package-error-package
 | 
				
			||||||
| 
						 | 
					@ -173,6 +175,11 @@ corresponds to the arguments expected by `set-path-environment-variable'."
 | 
				
			||||||
    (($ <search-path-specification> variable directories separator)
 | 
					    (($ <search-path-specification> variable directories separator)
 | 
				
			||||||
     `(,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.
 | 
					;; A package.
 | 
				
			||||||
(define-record-type* <package>
 | 
					(define-record-type* <package>
 | 
				
			||||||
  package make-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
 | 
					  (description package-description)              ; one or two paragraphs
 | 
				
			||||||
  (license package-license)
 | 
					  (license package-license)
 | 
				
			||||||
  (home-page package-home-page)
 | 
					  (home-page package-home-page)
 | 
				
			||||||
  (platforms package-platforms (default '()))
 | 
					  (supported-systems package-supported-systems    ; list of strings
 | 
				
			||||||
 | 
					                     (default %supported-systems))
 | 
				
			||||||
  (maintainers package-maintainers (default '()))
 | 
					  (maintainers package-maintainers (default '()))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  (properties package-properties (default '()))   ; alist for anything else
 | 
					  (properties package-properties (default '()))   ; alist for anything else
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Reference in a new issue