;; Run the unit tests. ;; ;; The unit tests contain arbitrary scheme code, but include a number ;; of (test-suite "label" expr ...) forms, using the macros in s7unit.scm. ;; ;; These can be used two ways: ;; ;; * `./beastie test-foo.scm` : ;; A file of tests can (load "s7unit.scm"), and when this is run ;; by beastie, the various `(test-suite ...)` forms will be evaluated. ;; * `./beastie s7unit.scm` or ;; `./beastie s7unit.scm test-foo.scm` or ;; `./beastie s7unit.scm test-foo.scm:label` : ;; Run `s7unit.scm` either with no arguments, or with one or more files ;; containing `(test-suite ...)` forms. If no arguments are ;; present, then search for all of the `test-*.scm` files and load them. ;; If the file is of the form `filename.scm:label`, then the suite runs ;; only the test with the given label in `filename.scm`. ;; ;; Exit with status 0 if all the test-suites pass. Exit non-zero if ;; any of the suites fail. Whenever an assertion fails, we abandon ;; the test-suite. ;; ;; Modules using this support should be structured as ;; ;; (test-suite ;; "suite name" ;; (assert-equal ...) ;; ...) ;; ... ;; (exit/failures) ; exit with non-zero status on any test-suite failures ;; ;; This file is part of Beastie ;; SPDX-FileCopyrightText: 2024 Norman Gray ;; SPDX-License-Identifier: BSD-2-Clause ;;(print-warning 'push #f) ; let individual files suppress these instead ;; here, we want everything to be printed fully (set! (*s7* 'print-length) (*s7* 'most-positive-fixnum)) (define-macro (%module-verbosity-flag%) 2048) (define *THIS-FILE* "s7unit.scm") ;; requires BEASTIE_LOAD_PATH=s7-yyyy-mm-dd ;; (load "debug.scm") ;; (set! (debug-stack) (make-vector 8)) ;; beastie.c sets the following, but if I want to get still ;; more prolix stacktraces, then we can increase the numbers here. ;; (set! (*s7* 'stacktrace-defaults) ;; '(30 80 120 80 #f)) ;; count the number of failed test-suite forms (define signal-failures (let ((total-failures 0)) (lambda args (if (null? args) total-failures (set! total-failures (+ total-failures (car args))))))) (module-provide signal-failures) (define/provide (exit/failures) (let ((nfails (signal-failures))) (if (> nfails 0) (let ((warnings (print-warning 'get-list))) (when (> (length warnings) 0) (format (current-error-port) " Warnings: ~s~%" (length warnings))) (format #t "Failures: ~s~%" nfails) (exit 1)) (begin ;; we delete temporaries only when we exit with success ;; (should we just delete them anyway?) (delete-temporary-files*!) (exit 0))))) (define/provide (red-text s) (sprintf " ~a " s)) (define/provide (green-text s) (sprintf " ~a " s)) ;; The macros below assume that there will be a function inc-good in ;; the environment, when they are expanded. (define (assert-equal* suite-label test-label good+ bail-out actual expected) (print-info "equal? ~s" test-label) (if (equal? actual expected) (good+) (bail-out (list suite-label test-label actual expected)))) ;; (ASSERT-EQUAL [test-label] actual expected) ;; Asserts that the two arguments are equal? ;; If `test-label` is present, it is used as the label for the string, ;; otherwise `actual` is used. (define-macro (assert-equal . args) (case (length args) ((2) `(assert-equal* suite-label (quote ,(car args)) inc-good bail-out ,(car args) ,(cadr args))) ((3) `(assert-equal* suite-label (quote ,(car args)) inc-good bail-out ,(cadr args) ,(caddr args))) (else (beastie-error 's7unit "wrong number of arguments to assert-equal")))) (define (assert-eqv* suite-label test-label good+ bail-out actual expected) (print-info "eqv? ~s" test-label) (if (eqv? actual expected) (good+) (bail-out (list suite-label test-label actual expected)))) ;; (ASSERT-EQV [test-label] actual expected) ;; Asserts that the two arguments are eqv? ;; If `test-label` is present, it is used as the label for the string, ;; otherwise `actual` is used. (define-macro (assert-eqv . args) (case (length args) ((2) `(assert-eqv* suite-label (quote ,(car args)) inc-good bail-out ,(car args) ,(cadr args))) ((3) `(assert-eqv* suite-label (quote ,(car args)) inc-good bail-out ,(cadr args) ,(caddr args))) (else (beastie-error 's7unit "wrong number of arguments to assert-eqv")))) (module-provide assert-equal assert-equal* assert-eqv assert-eqv*) (define (assert-exception* suite-label test-label good+ bail-out expected-tag expected-re thunk) (print-info "exception? ~s" test-label) (catch #t (lambda () (let ((v (thunk))) (bail-out (list suite-label test-label (format #f "succeeded with value ~s" v) (format #f "error:~s" expected-tag))))) (lambda (actual-tag . rest) ;(eprintf " actual-tag=~s~% rest=~s~% test-label=~s~%" actual-tag rest test-label) (if (eqv? expected-tag actual-tag) (if expected-re (if (regexp-match? expected-re (caar rest)) (good+) (begin (print-info "assert-exception: produced ~s" rest) (bail-out (list suite-label test-label (format #f "error with text: ~a" (caar rest)) ;; why oh why does the following produce error/garbage? ;;(format #f "error matching ~s" expected-re) "error matching regexp")))) (good+)) (begin (print-info "assert-exception: produced ~s" rest) (bail-out (list suite-label test-label (format #f "error:~s" actual-tag) (format #f "error:~s" expected-tag)))))))) ;; (ASSERT-EXCEPTION body ...) ;; (ASSERT-EXCEPTION :tag tag :body body :re re) ;; ;; The first case confirms that the (body ...) throws an exception of type 'beastie. ;; The second allows one to specify the expected tag (eg `:tag io-error`) ;; and a regexp (either as `(regexp ....)` or as a string) that the error message must match. (define-macro* (assert-exception (body #f) (tag beastie) (re #f)) `(assert-exception* suite-label (quote ,body) inc-good bail-out (quote ,tag) (let ((r ,re)) (if (string? r) (regexp r) r)) (lambda () ,body))) (module-provide assert-exception assert-exception*) (define (assert-true* suite-label test-label good+ bail-out actual) (print-info "true? ~s" test-label) (if (and (not (undefined? actual)) ;s7: # is non-#f, thus true actual) (good+) (bail-out (list suite-label test-label actual 'true)))) ;; Asserts that the argument is non-#f (define-macro (assert-true actual) `(assert-true* suite-label (quote ,actual) inc-good bail-out ,actual)) (module-provide assert-true assert-true*) (define (assert-false* suite-label test-label good+ bail-out actual) (print-info "false? ~s" test-label) (if actual (bail-out (list suite-label test-label actual #f)) (good+))) ;; Asserts that the argument is #f (define-macro (assert-false actual) `(assert-false* suite-label (quote ,actual) inc-good bail-out ,actual)) (module-provide assert-false assert-false*) (define (assert-fail* suite-label test-label msg bail-out) (print-info msg) (bail-out (list suite-label test-label msg "forced-fail"))) ;; Fail without testing anything. ;; If there is an 'expected' argument, then print that as an explanation (define-macro (assert-fail label . expected) `(assert-fail* suite-label ,label ,(if (null? expected) "forced-fail" (car expected)) bail-out)) (module-provide assert-fail assert-fail*) ;; (with-more-verbosity expr...) ;; evaluate the expr... with verbosity turned up (define-macro (with-more-verbosity expr . exprs) `(dynamic-wind (λ () (verbosity 'up)) (λ () ,expr . ,exprs) (λ () (verbosity 'down)))) (module-provide with-more-verbosity) ;; Given two objects A and B, which will typically (but not ;; necessarily) be lists, return #f if they are EQUAL?, and a string ;; otherwise, where the string aims to explain where the first ;; difference is. (define (list-first-diff a b) ;(eprintf "list-first-diff |~s| ? |~s|~%" a b) (cond ((equal? a b) #f) ;; ((null? a) (format #f "second has trailing ~s" b)) ;; ((null? b) (format #f "first has trailing ~s" a)) ((not (or (list? a) (list? b))) ;neither is a list (format #f "a=|~s| b=|~s| equal=~s~%" a b (equal? a b))) ((and (list? a) (list? b)) (let loop ((la a) (lb b)) #;(format (current-error-port) " la=~s lb=~s (type? la ~s, type? lb ~s, eq? ~s, equal? ~s eqv? ~s equivalent? ~s)~%" la lb (type-of la) (type-of lb) (eq? la lb) (eqv? la lb) (equal? la lb) (equivalent? la lb)) ;; a and b can't both be null, or else they would have matched the first stanza (cond ((null? la) (format #f "a null, b=~s" lb)) ((null? lb) (format #f "b null, a=~s" la)) ((and (list? la) (list? lb)) (let ((diff (list-first-diff (car la) (car lb)))) (or diff (loop (cdr la) (cdr lb))))) (else ;improper list? (if (equal? la lb) #f (format #f "a=~s b=~s" la lb)))))) (else (format #f "~s and ~s are not the same type of thing" a b)))) (define (string-first-diff a b) (let loop ((al (string->list a)) (bl (string->list b)) (pos 0)) (cond ((and (null? al) (null? bl)) "Not difference") ((null? al) (sprintf "first list short")) ((null? bl) (sprintf "second list short")) ((char=? (car al) (car bl)) (loop (cdr al) (cdr bl) (+ pos 1))) (else (sprintf "differ at pos ~a: ~a != ~a: ~s vs. ~s" pos (if (char-graph? (car al)) (car al) (sprintf "0x~x" (char->integer (car al)))) (if (char-graph? (car bl)) (car bl) (sprintf "0x~x" (char->integer (car bl)))) (list->string (if (< (length al) 10) al (take al 10))) (list->string (if (< (length bl) 10) bl (take bl 10)))))))) ;; Produce a report of a failure. ;; This is potentially usable by modules importing this one. (define/provide (report-failure failure) (let ((suite-label (car failure)) (test-label (cadr failure)) (actual (caddr failure)) (expected (cadddr failure))) (format #t " ~a: ~a\t-> ~a~% ~a: ~s~% ~a: ~s~%" suite-label test-label (red-text "failed") (red-text "actual") actual (green-text "expected") expected) (cond ((and (string? actual) (string? expected)) (format #t "Difference: ~a~%" (string-first-diff actual expected))) ((and (list? actual) (list? expected)) (format #t "Difference:~%~a~%" (list-first-diff actual expected)))) #f)) ;; Macro: TEST-SUITE string? . body ;; The body contains a number of (assert-equal actual expected) forms. ;; These are evaluated, and any which fail break out of the suite. ;; The expanded form evaluates to (ngood . nfail) (define-macro (test-suite label . body) `(let* ((ngood 0) (inc-good (lambda () (set! ngood (+ ngood 1))))) (catch #t (λ () (catch 'beastie (λ () (let* ((suite-label ,label) (failure (call-with-exit (lambda (bail-out) ,@body #f)))) (if failure (begin (report-failure failure) (signal-failures 1) (cons ngood 1)) (let ((label-len (string-length ,label)) (print-width 60) (s (if (= ngood 1) " " "s"))) (if (> label-len print-width) (format #t " ~a:~3d test~a OK~%" (substring ,label 0 print-width) ngood s) (format #t " ~a~a:~3d test~a OK~%" ,label (make-string (- print-width label-len) #\space) ngood s)) (cons ngood 0))))) (λ (tag info) ;; INFO is (string? assq?) (from beastie-error/assoc) ;; note: the (stacktrace) isn't useful at this point; ;; it's usefully called in (beastie-error) instead. (let ((msg (car info)) (assoc (cadr info))) (eprintf "~a (beastie) in test-suite ~s: ~a~%~a~%" (red-text "exception") ,label msg (if (null? assoc) "" assoc)) (signal-failures 1) (cons ngood 1))))) (λ (tag info) ;; The 'error-code in the (owlet) should give _some_ ;; indication of where this code is, but it may be ;; (heuristically?) a level up from the actual problem. ;; The 'error-line here doesn't help us: if this is in a ;; module, taken from util-extra.c, the line numbers are ;; unrelated to the source files. (eprintf "~a in test-suite ~a (~s):~%~a~%[caused near ~s]~%" (red-text "exception") ,label tag (apply sprintf info) ((owlet) 'error-code)) (when (verbosity? trace) ;; this is almost never useful! ;; In fact, this is _so_ un-useful I strongly suspect I'm using it wrongly. (eprintf "stacktrace:~%") (display (((owlet) 'stacktrace))) (newline)) (signal-failures 1) (cons ngood 1))))) (module-provide test-suite) (define (make-accumulator) (let ((res '())) (λ args (if (null? args) (reverse res) (set! res (cons (car args) res)))))) ;; LOAD/TEST-ENV : string? [string?] -> list? ;; Loads a file FN, handling (test-suite...) forms within it. ;; Evaluates to a list (filename ngood nbad nsuites) ;; If the second argument is present, then it names a test-suite which ;; should be run and the others skipped. (define (load/test-env fn . rest) (let ((acc (make-accumulator)) (outer-test-suite test-suite) (outer-load load) (outer-module module) (*envname* (sprintf "env/~a" fn))) ;see env->string/debug (define-macro (test-suite label . body) `(cond ((null? rest) (acc (outer-test-suite ,label . ,body))) ((string=? (car rest) ,label) (acc (outer-test-suite ,label . ,body))) (else '()))) (define (exit/failures) #f) ;dummy (define (signal-failures args) #f) (define *current-test-env* (curlet)) (define (load fn) ;; this is the normal load function (ie, that in runtime.scm), ;; but we avoid re-loading this file, and we load only in the ;; current environment (unless (and (string? fn) (string=? fn *THIS-FILE*)) (outer-load fn *current-test-env*))) ;; adjust (module ...) so that it skips any attempt to reload "s7unit.scm" (define-macro (module fn . fns) (let ((thinned (filter (λ (f) (not (and (string? f) (string=? f "s7unit.scm")))) ;can't use *THIS-FILE* here (cons fn fns)))) (if (null? thinned) '() `(outer-module . ,thinned)))) (load fn) (let ((results (acc))) ;; (outer-test-suite) returns (n-passed . 0) if all of the enclosed ;; tests passed, and (n-passed . 1) if one of them failed. ;; Thus the accumulator returns a list of such pairs, one per test-suite. ;; Turn these into a result for this file. (list fn (apply + (map car results)) ;ngood (apply + (map cdr results)) ;number of failing suites (length results))))) ;; Run all of the test-suites in the files in the list argument. ;; Return #t if all pass. (define (run-tests/file-list files) (let ((all-results (map (λ (fn) (cond ((string-index fn #\:) => (λ (colon) (let ((file (substring fn 0 colon)) (test (substring fn (+ colon 1)))) (printf "~a (~a)...~%" file test) (load/test-env file test)))) (else (printf "~a ...~%" fn) (load/test-env fn)))) files))) ;(printf "all-results=~s~%" all-results) (let ((n-tests (length all-results)) (n-good (apply + (map cadr all-results))) (n-failed-suites (apply + (map caddr all-results))) (n-suites (apply + (map cadddr all-results)))) (if (= n-failed-suites 0) (printf "~%~a file~p : ~a tests : all ~a test-suites pass~%~a~%" n-tests n-tests n-good n-suites (green-text "OK")) (printf "~%~a file~p : ~a tests : ~a/~a test-suites failed~%~a~%" n-tests n-tests n-good n-failed-suites n-suites (red-text "FAILURES"))) (= n-failed-suites 0)))) (define *temporary-files* '()) ;; Call PROC, with output sent to the given file, ;; and register the file as a temporary one -- see DELETE-TEMPORARY-FILES*! (define/provide (with-output-to-temporary-file fn proc) (with-output-to-file fn proc) (set! *temporary-files* (cons fn *temporary-files*)) fn) (define (delete-temporary-files*!) (for-each delete-file *temporary-files*) (set! *temporary-files* '())) (define/provide (file->list-of-lines fn) (with-input-from-file fn (λ () (let loop ((line (read-line)) (res '())) (if (eof-object? line) (reverse! res) (loop (read-line) (cons line res))))))) ;; If this file is itself being run by beastie, then the first ;; string in the *command-line* is this file's name, *THIS-FILE*. ;; In this case, call RUN-TESTS/FILE-LIST on the remaining list of arguments; ;; if there are no arguments, the call it on all of the files ;; test-*.scm. (define s7unit-is-main? (receive (base fn isdir?) (split-path (car *command-line*)) (string=? fn *THIS-FILE*))) (when s7unit-is-main? (define (is-test-file? fn) (and (string-prefix? "test-" fn) (string-suffix? ".scm" fn))) (let ((all-good? (run-tests/file-list (let ((input-files (cdr *command-line*))) (if (null? input-files) (sort! (filter is-test-file? (directory->list ".")) string