diff options
Diffstat (limited to '')
| -rwxr-xr-x | tests/run-tests.scm | 165 |
1 files changed, 41 insertions, 124 deletions
diff --git a/tests/run-tests.scm b/tests/run-tests.scm index 5270636e..d3ba53f8 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -16,136 +16,27 @@ fi (define here (dirname (current-filename))) (use-modules (hnh util path)) -(add-to-load-path (path-append (dirname here) "scripts")) (use-modules (srfi srfi-1) (srfi srfi-64) (srfi srfi-88) - (hnh util) - (ice-9 ftw) + ((hnh util io) :select (call-with-tmpfile)) (ice-9 format) - (ice-9 pretty-print) (ice-9 getopt-long) (ice-9 match) + (ice-9 regex) + ((ice-9 popen) + :select (open-pipe* + close-pipe)) + ((ice-9 rdelim) :select (read-string)) (system vm coverage) - ((all-modules) :select (fs-find)) + ((hnh module-introspection all-modules) :select (fs-find)) + + (hnh test testrunner) ) - -(define (µs x) - (* x #e1e6)) - -(define (transform-time-of-day tod) - (+ (* (µs 1) (car tod)) - (cdr tod))) - -(define verbose? (make-parameter #f)) - -(define (escaped sequence string) - (format #f "\x1b[~am~a\x1b[m" sequence string)) - -(define (green s) (escaped 32 s)) -(define (red s) (escaped 31 s)) -(define (yellow s) (escaped 33 s)) -(define (bold s) (escaped 1 s)) - -(define (make-indent depth) - (make-string (* 2 depth) #\space)) - -(define (construct-test-runner) - (define runner (test-runner-null)) - (define depth 0) - ;; end of individual test case - (test-runner-on-test-begin! runner - (lambda (runner) - (test-runner-aux-value! runner (transform-time-of-day (gettimeofday))))) - (test-runner-on-test-end! runner - (lambda (runner) - (when (verbose?) (display (make-indent depth))) - (case (test-result-kind runner) - ((pass) (display (green "X"))) - ((fail) (display (red "E"))) - ((xpass) (display (yellow "X"))) - ((xfail) (display (yellow "E"))) - ((skip) (display (yellow "-")))) - (when (or (verbose?) (eq? 'fail (test-result-kind))) - (format #t " ~a~%" - (cond ((test-runner-test-name runner) - (negate string-null?) => identity) - ((test-result-ref runner 'expected-value) - => (lambda (p) (with-output-to-string (lambda () (display (bold "[SOURCE]: ")) (truncated-print p width: 60)))))))) - (when (eq? 'fail (test-result-kind)) - (cond ((test-result-ref runner 'actual-error) - => (lambda (err) - (if (and (list? err) - (= 5 (length err))) - (let ((err (list-ref err 0)) - (proc (list-ref err 1)) - (fmt (list-ref err 2)) - (args (list-ref err 3))) - (format #t "~a~a in ~a: ~?~%" - (make-indent (1+ depth)) - err proc fmt args)) - (format #t "~aError: ~s~%" (make-indent (1+ depth)) err)))) - (else - (let ((unknown-expected (gensym)) - (unknown-actual (gensym))) - (let ((expected (test-result-ref runner 'expected-value unknown-expected)) - (actual (test-result-ref runner 'actual-value unknown-actual))) - (if (eq? expected unknown-expected) - (format #t "~aAssertion failed, received ~s~%" - (make-indent (1+ depth)) actual) - (format #t "~aExpected: ~s~%~aReceived: ~s~%" - (make-indent (1+ depth)) expected - (make-indent (1+ depth)) actual)))))) - (format #t "~aNear ~a:~a~%" - (make-indent (1+ depth)) - (test-result-ref runner 'source-file) - (test-result-ref runner 'source-line)) - (pretty-print (test-result-ref runner 'source-form) - (current-output-port) - per-line-prefix: (string-append (make-indent (1+ depth)) "> ") - )) - - (let ((start (test-runner-aux-value runner)) - (end (transform-time-of-day (gettimeofday)))) - (when (< (µs 1) (- end start)) - (format #t "~%Slow test: ~s, took ~a~%" - (test-runner-test-name runner) - (exact->inexact (/ (- end start) (µs 1))) - ))))) - - ;; on start of group - (test-runner-on-group-begin! runner - ;; count is number of #f - (lambda (runner name count) - (if (<= depth 1) - (format #t "~a ~a ~a~%" - (make-string 10 #\=) - name - (make-string 10 #\=)) - (when (verbose?) - (format #t "~a~a~%" (make-string (* depth 2) #\space) name))) - (set! depth (1+ depth)))) - (test-runner-on-group-end! runner - (lambda (runner) - (set! depth (1- depth)) - (when (<= depth 1) - (newline)))) - ;; after everything else is done - (test-runner-on-final! runner - (lambda (runner) - (format #t "Guile version ~a~%~%" (version)) - (format #t "pass: ~a~%" (test-runner-pass-count runner)) - (format #t "fail: ~a~%" (test-runner-fail-count runner)) - (format #t "xpass: ~a~%" (test-runner-xpass-count runner)) - (format #t "xfail: ~a~%" (test-runner-xfail-count runner)) - )) - - runner) - (test-runner-factory construct-test-runner) @@ -203,9 +94,6 @@ fi ;; (format #t "Running on:~%~y~%" files) -(awhen (option-ref options 'only #f) - (set! files (list (path-append "test" it)))) - ((@ (hnh util exceptions) warnings-are-errors) #t) @@ -240,9 +128,38 @@ fi (test-begin "suite") -(awhen (option-ref options 'skip #f) - (format #t "Skipping ~s~%" it) - (test-skip it)) + +(define onlies + (let %loop ((args (command-line)) (onlies '())) + (define* (loop args key: only) + (if only + (%loop args (cons only onlies)) + (%loop args onlies))) + (if (null? args) + onlies + (cond ((string-match "^--skip(=(.*))?$" (car args)) + => (lambda (m) + (cond ((match:substring m 2) + => (lambda (s) + (format #t "Skipping ~s~%" s) + (test-skip s) + (loop (cdr args)))) + (else (format #t "Skipping ~s~%" (cadr args)) + (test-skip (cadr args)) + (loop (cddr args)))))) + ((string-match "^--only(=(.*))?$" (car args)) + => (lambda (m) + (cond ((match:substring m 2) + => (lambda (s) + (loop (cdr args) only: s))) + (else (loop (cddr args) only: (cadr args)))))) + (else (loop (cdr args))))))) + +(unless (null? onlies) + (set! files + (map (lambda (x) (path-append "test" x)) + ;; reverse only until I have built a dependency graph for tests + (reverse onlies)))) (finalizer (lambda () (for-each (lambda (f) (catch/print-trace (lambda () (test-group f (load f))))) files))) |