From d2126820613a39be0a8724680e5e4e4ee38ddf84 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 12 May 2019 16:58:22 +0100 Subject: Add a (tests driver) module Using the test driver from build-aux/test-driver.scm, as this shows the test errors when tests fail. --- Makefile.am | 3 +- tests/driver.scm | 115 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 117 insertions(+), 1 deletion(-) create mode 100644 tests/driver.scm diff --git a/Makefile.am b/Makefile.am index 3ad58b8..b0ab4ce 100644 --- a/Makefile.am +++ b/Makefile.am @@ -56,7 +56,8 @@ SOURCES = \ guix-data-service/web/sxml.scm \ guix-data-service/web/query-parameters.scm \ guix-data-service/web/util.scm \ - guix-data-service/web/view/html.scm + guix-data-service/web/view/html.scm \ + tests/driver.scm TEST_EXTENSIONS = .scm diff --git a/tests/driver.scm b/tests/driver.scm new file mode 100644 index 0000000..6dc79fb --- /dev/null +++ b/tests/driver.scm @@ -0,0 +1,115 @@ +;;; Copyright © 2015, 2016 Mathieu Lirzin +;;; Copyright © 2019 Christopher Baines +;;; +;;; This program 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. +;;; +;;; This program 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 this program. If not, see . + +(define-module (tests driver) + #:use-module (ice-9 pretty-print) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64) + #:export (setup-runner)) + +(define* (test-display field value #:optional (port (current-output-port)) + #:key pretty?) + "Display \"FIELD: VALUE\\n\" on PORT." + (if pretty? + (begin + (format port "~A:~%" field) + (pretty-print value port #:per-line-prefix "+ ")) + (format port "~A: ~S~%" field value))) + +(define* (result->string symbol #:key colorize?) + "Return SYMBOL as an upper case string. Use colors when COLORIZE is #t." + (let ((result (string-upcase (symbol->string symbol)))) + (if colorize? + (string-append (case symbol + ((pass) "") ;green + ((xfail) "") ;light green + ((skip) "") ;blue + ((fail xpass) "") ;red + ((error) "")) ;magenta + result + "") ;no color + result))) + +(define* (test-runner-gnu #:key color? brief? out-port trs-port) + "Return an custom SRFI-64 test runner. COLOR? specifies whether to use colors, +and BRIEF?, well, you know. OUT-PORT and TRS-PORT must be output ports. The +current output port is supposed to be redirected to a '.log' file." + + (define (test-on-test-begin-gnu runner) + ;; Procedure called at the start of an individual test case, before the + ;; test expression (and expected value) are evaluated. + (let ((result (cute assq-ref (test-result-alist runner) <>))) + (format #t "location: ~A~%" + (string-append (result 'source-file) ":" + (number->string (result 'source-line)))) + (test-display "source" (result 'source-form) #:pretty? #t))) + + (define (test-on-test-end-gnu runner) + ;; Procedure called at the end of an individual test case, when the result + ;; of the test is available. + (let* ((results (test-result-alist runner)) + (result? (cut assq <> results)) + (result (cut assq-ref results <>))) + (unless brief? + ;; Display the result of each test case on the console. + (format out-port "~A: ~A~%" + (result->string (test-result-kind runner) #:colorize? color?) + (test-runner-test-name runner))) + (when (result? 'expected-value) + (test-display "expected-value" (result 'expected-value))) + (when (result? 'expected-error) + (test-display "expected-error" (result 'expected-error) #:pretty? #t)) + (when (result? 'actual-value) + (test-display "actual-value" (result 'actual-value))) + (when (result? 'actual-error) + (test-display "actual-error" (result 'actual-error) #:pretty? #t)) + (format #t "result: ~a~%" (result->string (result 'result-kind))) + (newline) + (format trs-port ":test-result: ~A ~A~%" + (result->string (test-result-kind runner)) + (test-runner-test-name runner)))) + + (define (test-on-group-end-gnu runner) + ;; Procedure called by a 'test-end', including at the end of a test-group. + (let ((fail (or (positive? (test-runner-fail-count runner)) + (positive? (test-runner-xpass-count runner)))) + (skip (or (positive? (test-runner-skip-count runner)) + (positive? (test-runner-xfail-count runner))))) + ;; XXX: The global results need some refinements for XPASS. + (format trs-port ":global-test-result: ~A~%" + (if fail "FAIL" (if skip "SKIP" "PASS"))) + (format trs-port ":recheck: ~A~%" + (if fail "yes" "no")) + (format trs-port ":copy-in-global-log: ~A~%" + (if (or fail skip) "yes" "no")) + (when brief? + ;; Display the global test group result on the console. + (format out-port "~A: ~%" + (result->string (if fail 'fail (if skip 'skip 'pass)) + #:colorize? color?))) + #f)) + + (let ((runner (test-runner-null))) + (test-runner-on-test-begin! runner test-on-test-begin-gnu) + (test-runner-on-test-end! runner test-on-test-end-gnu) + (test-runner-on-group-end! runner test-on-group-end-gnu) + (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) + runner)) + +(define (setup-runner) + (test-runner-current (test-runner-gnu))) + +(setup-runner) -- cgit v1.2.3