From 567c28e71716cb709a49dec8d1c60be9ad879f80 Mon Sep 17 00:00:00 2001 From: Wojtek Kosior Date: Tue, 5 Dec 2023 23:13:36 +0100 Subject: Initial commit. --- src/guile/Makefile.am | 46 ++++ src/guile/myra-test-utils.scm | 95 +++++++ src/guile/myra-test-utils/driver.scm | 284 +++++++++++++++++++++ src/guile/myra-test-utils/driver.scm.ChangeLog.in | 91 +++++++ .../driver.scm.ChangeLog.in.license | 5 + 5 files changed, 521 insertions(+) create mode 100644 src/guile/Makefile.am create mode 100644 src/guile/myra-test-utils.scm create mode 100755 src/guile/myra-test-utils/driver.scm create mode 100644 src/guile/myra-test-utils/driver.scm.ChangeLog.in create mode 100644 src/guile/myra-test-utils/driver.scm.ChangeLog.in.license (limited to 'src') diff --git a/src/guile/Makefile.am b/src/guile/Makefile.am new file mode 100644 index 0000000..dfbec85 --- /dev/null +++ b/src/guile/Makefile.am @@ -0,0 +1,46 @@ +# SPDX-License-Identifier: CC0-1.0 +# +# Copyright (C) 2023 Wojtek Kosior + +GUILE_SOURCE_FILES = \ + $(PACKAGE).scm \ + $(PACKAGE)/driver.scm + +GUILE_OBJECT_FILES = $(GUILE_SOURCE_FILES:.scm=.go) + +gobjdir = $(libdir)/guile/@GUILE_EFFECTIVE_VERSION@/site-ccache +nobase_gobj_DATA = $(GUILE_OBJECT_FILES) + +scmdir = $(datarootdir)/guile/site/@GUILE_EFFECTIVE_VERSION@ +nobase_dist_scm_DATA = $(GUILE_SOURCE_FILES) + +.scm.go: + $(top_builddir)/pre-inst-env $(GUILD) compile --output=$@ $< + +changelogdir = $(docdir) +nobase_dist_changelog_DATA = \ + myra-test-utils/driver.scm.ChangeLog \ + myra-test-utils/driver.scm.ChangeLog.in.license + +myra-test-utils/driver.scm.ChangeLog: myra-test-utils/driver.scm.ChangeLog.in + test -d myra-test-utils || mkdir myra-test-utils + (if test -d $(top_srcdir)/.git; then \ + cd $(srcdir) && git log \ + --grep='^Initial commit\.$$' --invert-grep \ + --after=2023-12-06T00+01:00 \ + --pretty='%as %an <%ae>%n%n%B' \ + myra-test-utils/driver.scm; \ + fi) | \ + $(AWK) '{line_prefix = " "} \ + /^(20[0-9]{2}(-[0-9]{2}){2}.*>)?$$/ {line_prefix = ""} \ + {print line_prefix $$0}' > $@ + cat $< >> $@ + +dist-hook: + cp $(distdir)/myra-test-utils/driver.scm.ChangeLog \ + $(distdir)/myra-test-utils/driver.scm.ChangeLog.in + $(SED) --expression='s/^SPDX.*/!!! PLEASE UPDATE THIS FILE… \0 !!!/' \ + --in-place \ + $(distdir)/myra-test-utils/driver.scm.ChangeLog.in.license + +MOSTLYCLEANFILES = $(GUILE_OBJECT_FILES) $(nobase_dist_changelog_DATA) diff --git a/src/guile/myra-test-utils.scm b/src/guile/myra-test-utils.scm new file mode 100644 index 0000000..4342539 --- /dev/null +++ b/src/guile/myra-test-utils.scm @@ -0,0 +1,95 @@ +;;; SPDX-License-Identifier: CC0-1.0 +;;; +;;; Copyright (C) 2023 Wojtek Kosior + +(define-module (myra-test-utils) + #:use-module ((srfi srfi-26) #:select(cut)) + #:use-module ((srfi srfi-34) #:select (guard raise)) + #:use-module ((srfi srfi-35) #:select (condition-type? condition-has-type?)) + #:use-module ((srfi srfi-64) #:prefix srfi-64:) + #:use-module ((ice-9 control) #:select (let/ec)) + #:use-module ((ice-9 match) #:select (match)) + #:use-module ((system repl error-handling) + #:select (call-with-error-handling)) + #:re-export ((srfi-64:test-group . test-group)) + #:export (%interactive-debugging + + test-assert + test-eq + test-eqv + test-equal + test-approximate + test-error + + call-with-fixtures + with-fixtures + test-group-with-fixtures)) + +(define %interactive-debugging + (make-parameter #f)) + +(define (wrap-call thunk) + (if (%interactive-debugging) + (call-with-error-handling thunk) + (thunk))) + +(define-syntax-rule (wrap test-expr) + (wrap-call (lambda () test-expr))) + +(define-syntax-rule (test-assert stuff ... test-expr) + (srfi-64:test-assert stuff ... (wrap test-expr))) + +(define-syntax-rule (test-eq stuff ... test-expr) + (srfi-64:test-eq stuff ... (wrap test-expr))) + +(define-syntax-rule (test-eqv stuff ... test-expr) + (srfi-64:test-eqv stuff ... (wrap test-expr))) + +(define-syntax-rule (test-equal stuff ... test-expr) + (srfi-64:test-equal stuff ... (wrap test-expr))) + +(define-syntax-rule (test-approximate stuff ... test-expr error) + (srfi-64:test-approximate stuff ... (wrap test-expr) error)) + +(define %exception-object-indicator + (gensym)) + +(define (except-error error-type thunk) + (match (let/ec escape + (guard (unexpected-ex (#t + (escape unexpected-ex))) + (wrap-call (lambda () + (guard (ex + ((or (and (condition-type? error-type) + (condition-has-type? ex error-type)) + (and (procedure? error-type) + (error-type ex)) + (eq? error-type #t)) + (escape (list %exception-object-indicator + ex)))) + (const (thunk))))))) + (((? (cut eq? %exception-object-indicator <>)) ex) + (raise ex)) + (result + result))) + +(define-syntax test-error + (syntax-rules () + ((test-error test-expr) + (test-error #t test-expr)) + ((test-error stuff ... error-type test-expr) + (srfi-64:test-error stuff ... #t + (except-error error-type (lambda () test-expr)))))) + +(define (call-with-fixtures fixtures thunk) + (match fixtures + (() + (thunk)) + ((fixture . rest) + (fixture (cut call-with-fixtures rest thunk))))) + +(define-syntax-rule (with-fixtures fixtures body ...) + (call-with-fixtures fixtures (lambda () body ...))) + +(define-syntax-rule (test-group-with-fixtures name fixtures body ...) + (with-fixtures fixtures (srfi-64:test-group name body ...))) diff --git a/src/guile/myra-test-utils/driver.scm b/src/guile/myra-test-utils/driver.scm new file mode 100755 index 0000000..1cdd4ff --- /dev/null +++ b/src/guile/myra-test-utils/driver.scm @@ -0,0 +1,284 @@ +#!/bin/sh +exec guile --no-auto-compile -e main -s "$0" "$@" +!# +;;;; test-driver.scm - Guile test driver for Automake testsuite harness + +(define script-version "2021-02-02.05") ;UTC + +;;; Copyright © 2015, 2016 Mathieu Lirzin +;;; Copyright © 2021 Maxim Cournoyer +;;; +;;; 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 . + +;;;; Commentary: +;;; +;;; This script provides a Guile test driver using the SRFI-64 Scheme API for +;;; test suites. SRFI-64 is distributed with Guile since version 2.0.9. +;;; +;;;; Code: + +(use-modules (ice-9 format) + (ice-9 getopt-long) + (ice-9 pretty-print) + (ice-9 regex) + (srfi srfi-1) + (srfi srfi-19) + (srfi srfi-26) + (srfi srfi-64)) + +(define (show-help) + (display "Usage: + test-driver --test-name=NAME --log-file=PATH --trs-file=PATH + [--expect-failure={yes|no}] [--color-tests={yes|no}] + [--select=REGEXP] [--exclude=REGEXP] [--errors-only={yes|no}] + [--enable-hard-errors={yes|no}] [--brief={yes|no}}] + [--show-duration={yes|no}] [--] + TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS] +The '--test-name' option is mandatory. The '--select' and '--exclude' options +allow selecting or excluding individual test cases via a regexp, respectively. +The '--errors-only' option can be set to \"yes\" to limit the logged test case +metadata to only those test cases that failed. When set to \"yes\", the +'--brief' option disables printing the individual test case result to the +console. When '--show-duration' is set to \"yes\", the time elapsed per test +case is shown.\n")) + +(define %options + '((test-name (value #t)) + (log-file (value #t)) + (trs-file (value #t)) + (select (value #t)) + (exclude (value #t)) + (errors-only (value #t)) + (color-tests (value #t)) + (expect-failure (value #t)) ;XXX: not implemented yet + (enable-hard-errors (value #t)) ;not implemented in SRFI-64 + (brief (value #t)) + (show-duration (value #t)) + (help (single-char #\h) (value #f)) + (version (single-char #\V) (value #f)))) + +(define (option->boolean options key) + "Return #t if the value associated with KEY in OPTIONS is \"yes\"." + (and=> (option-ref options key #f) (cut string=? <> "yes"))) + +(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))) + + +;;; +;;; SRFI 64 custom test runner. +;;; + +(define* (test-runner-gnu test-name #:key color? brief? errors-only? + show-duration? + (out-port (current-output-port)) + (trs-port (%make-void-port "w")) + select exclude) + "Return an custom SRFI-64 test runner. TEST-NAME is a string specifying the +file name of the current the test. COLOR? specifies whether to use colors. +When BRIEF? is true, the individual test cases results are masked and only the +summary is shown. ERRORS-ONLY? reduces the amount of test case metadata +logged to only that of the failed test cases. OUT-PORT and TRS-PORT must be +output ports. OUT-PORT defaults to the current output port, while TRS-PORT +defaults to a void port, which means no TRS output is logged. SELECT and +EXCLUDE may take a regular expression to select or exclude individual test +cases based on their names." + + (define test-cases-start-time (make-hash-table)) + + (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 ((test-case-name (test-runner-test-name runner)) + (start-time (current-time time-monotonic))) + (hash-set! test-cases-start-time test-case-name start-time))) + + (define (test-skipped? runner) + (eq? 'skip (test-result-kind runner))) + + (define (test-failed? runner) + (not (or (test-passed? runner) + (test-skipped? runner)))) + + (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 <>)) + (test-case-name (test-runner-test-name runner)) + (start (hash-ref test-cases-start-time test-case-name)) + (end (current-time time-monotonic)) + (time-elapsed (time-difference end start)) + (time-elapsed-seconds (+ (time-second time-elapsed) + (* 1e-9 (time-nanosecond time-elapsed))))) + (unless (or brief? (and errors-only? (test-skipped? runner))) + ;; Display the result of each test case on the console. + (format out-port "~a: ~a - ~a ~@[[~,3fs]~]~%" + (result->string (test-result-kind runner) #:colorize? color?) + test-name test-case-name + (and show-duration? time-elapsed-seconds))) + + (unless (and errors-only? (not (test-failed? runner))) + (format #t "test-name: ~A~%" (result 'test-name)) + (format #t "location: ~A~%" + (string-append (result 'source-file) ":" + (number->string (result 'source-line)))) + (test-display "source" (result 'source-form) #:pretty? #t) + (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 [~,3fs]~%" + (result->string (test-result-kind runner)) + (test-runner-test-name runner) time-elapsed-seconds))) + + (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: ~A~%" + (result->string (if fail 'fail (if skip 'skip 'pass)) + #:colorize? color?) + test-name)) + #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)) + + +;;; +;;; SRFI 64 test specifiers. +;;; +(define (test-match-name* regexp) + "Return a test specifier that matches a test name against REGEXP." + (lambda (runner) + (string-match regexp (test-runner-test-name runner)))) + +(define (test-match-name*/negated regexp) + "Return a negated test specifier version of test-match-name*." + (lambda (runner) + (not (string-match regexp (test-runner-test-name runner))))) + +;;; XXX: test-match-all is a syntax, which isn't convenient to use with a list +;;; of test specifiers computed at run time. Copy this SRFI 64 internal +;;; definition here, which is the procedural equivalent of 'test-match-all'. +(define (%test-match-all . pred-list) + (lambda (runner) + (let ((result #t)) + (let loop ((l pred-list)) + (if (null? l) + result + (begin + (if (not ((car l) runner)) + (set! result #f)) + (loop (cdr l)))))))) + + +;;; +;;; Entry point. +;;; + +(define (main . args) + (let* ((opts (getopt-long (command-line) %options)) + (option (cut option-ref opts <> <>))) + (cond + ((option 'help #f) (show-help)) + ((option 'version #f) (format #t "test-driver.scm ~A~%" script-version)) + (else + (let* ((log (and=> (option 'log-file #f) (cut open-file <> "w0"))) + (trs (and=> (option 'trs-file #f) (cut open-file <> "wl"))) + (out (duplicate-port (current-output-port) "wl")) + (test-name (option 'test-name #f)) + (select (option 'select #f)) + (exclude (option 'exclude #f)) + (test-specifiers (filter-map + identity + (list (and=> select test-match-name*) + (and=> exclude test-match-name*/negated)))) + (test-specifier (apply %test-match-all test-specifiers)) + (color-tests (if (assoc 'color-tests opts) + (option->boolean opts 'color-tests) + #t))) + (when log + (redirect-port log (current-output-port)) + (redirect-port log (current-warning-port)) + (redirect-port log (current-error-port))) + (test-with-runner + (test-runner-gnu test-name + #:color? color-tests + #:brief? (option->boolean opts 'brief) + #:errors-only? (option->boolean opts 'errors-only) + #:show-duration? (option->boolean + opts 'show-duration) + #:out-port out #:trs-port trs) + (test-apply test-specifier + (lambda _ + (load-from-path test-name)))) + (and=> log close-port) + (and=> trs close-port) + (close-port out)))) + (exit 0))) + +;;; Local Variables: +;;; eval: (add-hook 'write-file-functions 'time-stamp) +;;; time-stamp-start: "(define script-version \"" +;;; time-stamp-format: "%:y-%02m-%02d.%02H" +;;; time-stamp-time-zone: "UTC" +;;; time-stamp-end: "\") ;UTC" +;;; End: + +;;;; test-driver.scm ends here. diff --git a/src/guile/myra-test-utils/driver.scm.ChangeLog.in b/src/guile/myra-test-utils/driver.scm.ChangeLog.in new file mode 100644 index 0000000..b603b22 --- /dev/null +++ b/src/guile/myra-test-utils/driver.scm.ChangeLog.in @@ -0,0 +1,91 @@ +2021-02-02 Maxim Cournoyer + + build: Add a --show-duration option to the SCM test-driver. + + * build-aux/test-driver.scm (script-version): Update. + (show-help): Document it. + (%options): Add the 'show-duration' option. + (test-runner-gnu): Pass as a new argument. + [test-cases-start-time]: New inner variable. + [test-on-test-begin-gnu]: New hook, used to record the start time. + [test-on-test-end-gnu]: Conditionally print elapsed time. Record it as the + optional metadata in the test result file (.trs). + +2021-01-16 Maxim Cournoyer + + build: test-driver.scm: Allow running as a standalone script. + + * build-aux/test-driver.scm: Add an exec-based shebang and set the script + executable bit. + (main): Insert a newline after the version string is printed with --version. + +2021-01-18 Maxim Cournoyer + + build: test-driver.scm: Add a new '--errors-only' option. + + * build-aux/test-driver.scm (show-help): Add the help text for the + new '--errors-only' option. + (%options): Add the errors-only option. + (test-runner-gnu): Add the errors-only? parameter and update doc. Move the + logging of the test data after the test has completed, so a choice can be made + whether to keep it or discard it based on the value of the test result. + (main): Pass the errors-only? option to the driver. + +2021-01-17 Maxim Cournoyer + + build: test-driver.scm: Add test cases filtering options. + + * build-aux/test-driver.scm (show-help): Add help text for the new --select + and --exclude options. + (%options): Add the new select and exclude options. + (test-runner-gnu): Pass them to the test runner. Update doc. + (test-match-name*, test-match-name*/negated, %test-match-all): New variables. + (main): Compute the test specifier based on the values of the new options and + apply it to the current test runner when running the test file. + +2021-01-16 Maxim Cournoyer + + build: test-driver.scm: Enable colored test results by default. + + The Automake parallel test harness does its own smart detection of the + terminal color capability and always provides the --color-tests argument to + the driver. This change defaults the --color-tests argument to true when the + test driver is run on its own (not via Automake). + + * build-aux/test-driver.scm (main): Set the default value of the --color-tests + argument to true when it's not explicitly provided. + +2021-01-16 Maxim Cournoyer + + build: test-driver.scm: Make output redirection optional. + + This makes it easier (and less surprising) for users to experiment with the + custom Scheme test driver directly. The behavior is unchanged from Automake's + point of view. + + * build-aux/test-driver.scm (main): Make the --log-file and --trs-file + arguments optional and update doc. Only open, redirect and close a port to a log file when + the --log-file option is provided. Only open and close a port to a trs file + when the --trs-file option is provided. + (test-runner-gnu): Set OUT-PORT parameter default value to the current output + port. Set the TRS-PORT parameter default value to a void port. Update doc. + +2017-03-22 Ludovic Courtès + + build: 'test-driver.scm' prints Scheme values with 'write'. + + Previously it would print them with 'display', which was inconvenient. + + * build-aux/test-driver.scm (test-display): Use ~S for VALUE. + (test-runner-gnu): Use 'format' instead of 'test-display' for the test + name, location, and result kind. + +2015-10-26 Mathieu Lirzin + + build: Add a Guile custom test driver using SRFI-64. + + Before that '.log' files for scheme tests were fragmented and not + included in test-suite.log. This unifies the semantics of SRFI-64 API + with Automake test suite. + + * build-aux/test-driver.scm: New file. diff --git a/src/guile/myra-test-utils/driver.scm.ChangeLog.in.license b/src/guile/myra-test-utils/driver.scm.ChangeLog.in.license new file mode 100644 index 0000000..84313bb --- /dev/null +++ b/src/guile/myra-test-utils/driver.scm.ChangeLog.in.license @@ -0,0 +1,5 @@ +SPDX-License-Identifier: GPL-3.0-or-later + +Copyright © 2015, 2016 Mathieu Lirzin +Copyright © 2017 Ludovic Courtès +Copyright © 2021 Maxim Cournoyer -- cgit v1.2.3