From 98b65b5ff6b1dea0ad58b0f47dd163c32d0cbf6e Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 20 Jun 2016 22:34:13 +0200
Subject: 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'.
---
 gnu/tests.scm | 68 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 67 insertions(+), 1 deletion(-)

(limited to 'gnu/tests.scm')

diff --git a/gnu/tests.scm b/gnu/tests.scm
index 348b5ad40f..ea779ed6f0 100644
--- a/gnu/tests.scm
+++ b/gnu/tests.scm
@@ -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
-- 
cgit v1.2.3