1
0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2026-05-25 02:21:49 +02:00

tests: Add a mechanism to describe and discover system tests.

* gnu/tests.scm (<system-test>): New record type.
(write-system-test, test-modules, fold-system-tests)
(all-system-tests): New procedures.
* gnu/tests/base.scm (%test-basic-os): Turn into a <system-test>.
* gnu/tests/install.scm (%test-installed-os): Likewise.
* build-aux/run-system-tests.scm (%system-tests): Remove.
(run-system-tests): Use 'all-system-tests'.
This commit is contained in:
Ludovic Courtès
2016-06-20 22:34:13 +02:00
parent 2a6ba87086
commit 98b65b5ff6
5 changed files with 112 additions and 38 deletions
+67 -1
View File
@@ -18,12 +18,28 @@
(define-module (gnu tests)
#:use-module (guix gexp)
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (gnu system)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module ((gnu packages) #:select (scheme-modules))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (ice-9 match)
#:export (marionette-service-type
marionette-operating-system
define-os-with-source))
define-os-with-source
system-test
system-test?
system-test-name
system-test-value
system-test-description
system-test-location
fold-system-tests
all-system-tests))
;;; Commentary:
;;;
@@ -147,4 +163,54 @@ the system under test."
(use-modules modules ...)
(operating-system fields ...)))))))
;;;
;;; Tests.
;;;
(define-record-type* <system-test> system-test make-system-test
system-test?
(name system-test-name) ;string
(value system-test-value) ;%STORE-MONAD value
(description system-test-description) ;string
(location system-test-location (innate) ;<location>
(default (and=> (current-source-location)
source-properties->location))))
(define (write-system-test test port)
(match test
(($ <system-test> name _ _ ($ <location> file line))
(format port "#<system-test ~a ~a:~a ~a>"
name file line
(number->string (object-address test) 16)))
(($ <system-test> name)
(format port "#<system-test ~a ~a>" name
(number->string (object-address test) 16)))))
(set-record-type-printer! <system-test> write-system-test)
(define (test-modules)
"Return the list of modules that define system tests."
(scheme-modules (dirname (search-path %load-path "guix.scm"))
"gnu/tests"))
(define (fold-system-tests proc seed)
"Invoke PROC on each system test, passing it the test and the previous
result."
(fold (lambda (module result)
(fold (lambda (thing result)
(if (system-test? thing)
(proc thing result)
result))
result
(module-map (lambda (sym var)
(false-if-exception (variable-ref var)))
module)))
'()
(test-modules)))
(define (all-system-tests)
"Return the list of system tests."
(reverse (fold-system-tests cons '())))
;;; tests.scm ends here