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:
+67
-1
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user