Change <job-spec> and <job> semantics.

2 files changed, 81 insertions, 59 deletions

diff --git a/tests/gnu-system.scm b/tests/gnu-system.scm
index d58f47e..caacacd 100644
--- a/tests/gnu-system.scm
+++ b/tests/gnu-system.scm
@@ -66,33 +66,25 @@
     (timeout . ,(or (assoc-ref (package-properties package) 'timeout)
                     72000))))           ;20 hours by default
 
-(define (package-job-spec store job-name package system)
-  "Return a non evaluated job called JOB-NAME that builds PACKAGE on SYSTEM."
-  (make-job-spec
-   #:name
-   (string-append (symbol->string job-name) "." system)
-   #:procedure
-   (λ ()
-     (derivation-file-name
-      (parameterize ((%graft? #f))
-        (package-derivation store package system #:graft? #f))))
-   #:metadata
-   (package-metadata package)))
-
-(define (package-cross-job-spec store job-name package target system)
-  "Return a non evaluated job called TARGET.JOB-NAME that cross-builds PACKAGE
+(define (package-job store job-name package system)
+  "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
+  (make-job
+   #:name (string-append (symbol->string job-name) "." system)
+   #:derivation (derivation-file-name
+                 (parameterize ((%graft? #f))
+                   (package-derivation store package system #:graft? #f)))
+   #:metadata (package-metadata package)))
+
+(define (package-cross-job store job-name package target system)
+  "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE
 for TARGET on SYSTEM."
-  (make-job-spec
-   #:name
-   (string-append target "." (symbol->string job-name) "." system)
-   #:procedure
-   (λ ()
-     (derivation-file-name
-      (parameterize ((%graft? #f))
-        (package-cross-derivation store package target system
-                                  #:graft? #f))))
-   #:metadata
-   (package-metadata package)))
+  (make-job
+   #:name (string-append target "." (symbol->string job-name) "." system)
+   #:derivation (derivation-file-name
+                 (parameterize ((%graft? #f))
+                   (package-cross-derivation store package target system
+                                             #:graft? #f)))
+   #:metadata (package-metadata package)))
 
 (define %core-packages
   ;; Note: Don't put the '-final' package variants because (1) that's
@@ -115,21 +107,18 @@ for TARGET on SYSTEM."
   '("mips64el-linux-gnu"
     "mips64el-linux-gnuabi64"))
 
-(define (tarball-job-specs store system)
+(define (tarball-jobs store system)
   "Return Hydra jobs to build the self-contained Guix binary tarball."
   (list
-   (make-job-spec
-    #:name
-    (string-append "binary-tarball." system)
-    #:procedure
-    (λ ()
-      (derivation-file-name
-       (parameterize ((%graft? #f))
-         (run-with-store store
-           (mbegin %store-monad
-             (set-guile-for-build (default-guile))
-             (self-contained-tarball))
-           #:system system))))
+   (make-job
+    #:name (string-append "binary-tarball." system)
+    #:derivation (derivation-file-name
+                  (parameterize ((%graft? #f))
+                    (run-with-store store
+                      (mbegin %store-monad
+                        (set-guile-for-build (default-guile))
+                        (self-contained-tarball))
+                      #:system system)))
     #:metadata
     `((description . "Stand-alone binary Guix tarball")
       (long-description . "This is a tarball containing binaries of Guix and
@@ -138,11 +127,11 @@ all its dependencies, and ready to be installed on non-GuixSD distributions.")
       (home-page . ,%guix-home-page-url)
       (maintainers . ("bug-guix@gnu.org"))))))
 
-(define job-name
+(define %job-name
   ;; Return the name of a package's job.
   (compose string->symbol package-full-name))
 
-(define package->job-spec
+(define package->job
   (let ((base-packages
          (delete-duplicates
           (append-map (match-lambda
@@ -157,7 +146,7 @@ valid."
       (cond ((member package base-packages)
              #f)
             ((supported-package? package system)
-             (package-job-spec store (job-name package) package system))
+             (package-job store (%job-name package) package system))
             (else
              #f)))))
 
@@ -195,8 +184,8 @@ valid."
 
     (append-map (lambda (target)
                   (map (lambda (package)
-                         (package-cross-job-spec store (job-name package)
-                                                 package target system))
+                         (package-cross-job store (job-name package)
+                                            package target system))
                        %packages-to-cross-build))
                 (remove (either from-32-to-64? same?) %cross-targets)))
 
@@ -207,30 +196,30 @@ valid."
                   (case subset
                     ((all)
                      ;; Build everything, including replacements.
-                     (let ((all (fold-packages
-                                 (lambda (package result)
-                                   (if (package-replacement package)
-                                       (cons* package
-                                              (package-replacement package)
-                                              result)
-                                       (cons package result)))
-                                 '()))
-                           (job (lambda (package)
-                                  (package->job-spec store package system))))
-                       (append (filter-map job all)
-                               (tarball-job-specs store system)
+                     (let ((pkgs (fold-packages
+                                  (lambda (package result)
+                                    (if (package-replacement package)
+                                        (cons* package
+                                               (package-replacement package)
+                                               result)
+                                        (cons package result)))
+                                  '())))
+                       (append (filter-map (lambda (pkg)
+                                             (package->job store pkg system))
+                                           pkgs)
+                               (tarball-jobs store system)
                                (cross-jobs system))))
                     ((core)
                      ;; Build core packages only.
                      (append (map (lambda (package)
-                                    (package-job-spec store (job-name package)
-                                                      package system))
+                                    (package-job store (job-name package)
+                                                 package system))
                                   %core-packages)
                              (cross-jobs system)))
                     ((hello)
                      ;; Build hello package only.
                      (if (string=? system (%current-system))
-                         (list (package-job-spec store (job-name hello) hello system))
+                         (list (package-job store (%job-name hello) hello system))
                          '()))
                     (else
                      (error "unknown subset" subset))))
diff --git a/tests/hello-subset.scm b/tests/hello-subset.scm
new file mode 100644
index 0000000..3330142
--- /dev/null
+++ b/tests/hello-subset.scm
@@ -0,0 +1,33 @@
+;;;; hello-subset.scm - job specification test for hello subset.
+;;;
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Cuirass is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (cuirass job))
+
+;; In the common case jobs will be defined relative to the repository.
+;; However for testing purpose use local gnu-system.scm instead.
+(define (local-file file)
+  (string-append (dirname (current-filename)) "/" file))
+
+(make-job-spec
+ #:name "guix"
+ #:url "git://git.savannah.gnu.org/guix.git"
+ #:branch "master"
+ #:file (local-file "gnu-system.scm")
+ #:proc 'hydra-jobs
+ #:arguments '((subset . "hello")))