From 4e097f8606ddd911be6bc5eb43240cb7acee894d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 6 Oct 2014 19:14:47 +0200
Subject: [PATCH] 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.
---
 build-aux/hydra/gnu-system.scm | 88 +++++++++++++++++++---------------
 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