diff options
Diffstat (limited to 'src/guile')
| -rwxr-xr-x | src/guile/myra-test-utils/driver.scm | 86 |
1 files changed, 45 insertions, 41 deletions
diff --git a/src/guile/myra-test-utils/driver.scm b/src/guile/myra-test-utils/driver.scm index 1cdd4ff..bfb5a1f 100755 --- a/src/guile/myra-test-utils/driver.scm +++ b/src/guile/myra-test-utils/driver.scm @@ -1,12 +1,10 @@ -#!/bin/sh -exec guile --no-auto-compile -e main -s "$0" "$@" -!# -;;;; test-driver.scm - Guile test driver for Automake testsuite harness +;;; SPDX-License-Identifier: GPL-3.0-or-later AND CC0-1.0 -(define script-version "2021-02-02.05") ;UTC +;;;; driver.scm - Guile test driver for Automake testsuite harness ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2023 Wojtek Kosior <my-contribution-is-licensed-cc0@koszko.org> ;;; ;;; 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 @@ -28,14 +26,18 @@ exec guile --no-auto-compile -e main -s "$0" "$@" ;;; ;;;; 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-module (myra-test-utils driver) + #:use-module ((ice-9 format) #:select (format)) + #:use-module ((ice-9 getopt-long) #:select (getopt-long option-ref)) + #:use-module ((ice-9 pretty-print) #:select (pretty-print)) + #:use-module ((ice-9 regex) #:select (string-match)) + #:use-module ((srfi srfi-1) #:select (filter-map)) + #:use-module ((srfi srfi-19) #:prefix s19:) + #:use-module ((srfi srfi-26) #:select (cut)) + #:use-module ((srfi srfi-64) #:prefix s64:) + #:export (run-test-driver)) + +(define script-version "2023-12-06.16") ;UTC (define (show-help) (display "Usage: @@ -120,33 +122,35 @@ cases based on their names." (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))) + (let ((test-case-name (s64:test-runner-test-name runner)) + (start-time (s19:current-time s19:time-monotonic))) (hash-set! test-cases-start-time test-case-name start-time))) (define (test-skipped? runner) - (eq? 'skip (test-result-kind runner))) + (eq? 'skip (s64:test-result-kind runner))) (define (test-failed? runner) - (not (or (test-passed? runner) + (not (or (s64: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)) + (let* ((results (s64:test-result-alist runner)) (result? (cut assq <> results)) (result (cut assq-ref results <>)) - (test-case-name (test-runner-test-name runner)) + (test-case-name (s64: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))))) + (end (s19:current-time s19:time-monotonic)) + (time-elapsed (s19:time-difference end start)) + (time-elapsed-seconds (+ (s19:time-second time-elapsed) + (* 1e-9 (s19: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?) + (result->string (s64:test-result-kind runner) + #:colorize? color?) test-name test-case-name (and show-duration? time-elapsed-seconds))) @@ -168,15 +172,15 @@ cases based on their names." (newline)) (format trs-port ":test-result: ~A ~A [~,3fs]~%" - (result->string (test-result-kind runner)) - (test-runner-test-name runner) time-elapsed-seconds))) + (result->string (s64:test-result-kind runner)) + (s64: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))))) + (let ((fail (or (positive? (s64:test-runner-fail-count runner)) + (positive? (s64:test-runner-xpass-count runner)))) + (skip (or (positive? (s64:test-runner-skip-count runner)) + (positive? (s64: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"))) @@ -192,11 +196,11 @@ cases based on their names." 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) + (let ((runner (s64:test-runner-null))) + (s64:test-runner-on-test-begin! runner test-on-test-begin-gnu) + (s64:test-runner-on-test-end! runner test-on-test-end-gnu) + (s64:test-runner-on-group-end! runner test-on-group-end-gnu) + (s64:test-runner-on-bad-end-name! runner s64:test-on-bad-end-name-simple) runner)) @@ -206,12 +210,12 @@ cases based on their names." (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)))) + (string-match regexp (s64: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))))) + (not (string-match regexp (s64: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 @@ -232,8 +236,8 @@ cases based on their names." ;;; Entry point. ;;; -(define (main . args) - (let* ((opts (getopt-long (command-line) %options)) +(define (run-test-driver args) + (let* ((opts (getopt-long args %options)) (option (cut option-ref opts <> <>))) (cond ((option 'help #f) (show-help)) @@ -257,7 +261,7 @@ cases based on their names." (redirect-port log (current-output-port)) (redirect-port log (current-warning-port)) (redirect-port log (current-error-port))) - (test-with-runner + (s64:test-with-runner (test-runner-gnu test-name #:color? color-tests #:brief? (option->boolean opts 'brief) @@ -265,7 +269,7 @@ cases based on their names." #:show-duration? (option->boolean opts 'show-duration) #:out-port out #:trs-port trs) - (test-apply test-specifier + (s64:test-apply test-specifier (lambda _ (load-from-path test-name)))) (and=> log close-port) |