diff options
| -rw-r--r-- | module/hnh/test/testrunner.scm | 126 | ||||
| -rw-r--r-- | module/hnh/test/util.scm | 57 | ||||
| -rwxr-xr-x | tests/run-tests.scm | 159 |
3 files changed, 185 insertions, 157 deletions
diff --git a/module/hnh/test/testrunner.scm b/module/hnh/test/testrunner.scm new file mode 100644 index 00000000..384afd4b --- /dev/null +++ b/module/hnh/test/testrunner.scm @@ -0,0 +1,126 @@ +(define-module (hnh test testrunner) + :use-module (srfi srfi-64) + :use-module (hnh test util) + :use-module (ice-9 pretty-print) + :use-module (ice-9 format) + :export (verbose? construct-test-runner) + ) + +(define verbose? (make-parameter #f)) + +(define (pp form indent prefix-1) + (let ((prefix (make-string (+ (string-length indent) + (string-length prefix-1)) + #\space))) + (string-replace-head + (with-output-to-string + (lambda () (pretty-print + form + display?: #t + per-line-prefix: prefix + width: (- 79 (string-length indent))))) + (string-append indent prefix-1)))) + + +(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))) + (let ((indent (make-indent (1+ depth)))) + (if (eq? expected unknown-expected) + (format #t "~aAssertion failed~%" indent) + (begin + (display (pp expected indent "Expected: ")) + (display (pp actual indent "Received: ")) + (let ((d (diff (pp expected "" "") + (pp actual "" "")))) + (display + (string-join + (map (lambda (line) (string-append indent "|" line)) + (string-split d #\newline)) + "\n" 'suffix)))))))))) + (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) + diff --git a/module/hnh/test/util.scm b/module/hnh/test/util.scm new file mode 100644 index 00000000..3d51e162 --- /dev/null +++ b/module/hnh/test/util.scm @@ -0,0 +1,57 @@ +(define-module (hnh test util) + :use-module ((hnh util) :select (begin1)) + :use-module ((hnh util io) :select (call-with-tmpfile)) + :use-module (ice-9 pretty-print) + :use-module ((ice-9 rdelim) :select (read-string)) + :use-module ((ice-9 popen) + :select (open-pipe* + close-pipe)) + :export (µs + transform-time-of-day + green + red + yellow + bold + make-indent + string-replace-head + diff + )) + +(define (µs x) + (* x #e1e6)) + +(define (transform-time-of-day tod) + (+ (* (µs 1) (car tod)) + (cdr tod))) + +(define (escaped sequence string) + (format #f "\x1b[~am~a\x1b[m" sequence string)) + +;; Terminal output formatting. Doesn NOT compose +(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 (string-replace-head s1 s2) + (string-replace s1 s2 + 0 (string-length s2))) + + +(define diff-cmd + ;; '("diff") + '("git" "diff" "--no-index" "--color-moved=default" "--color=always"; "--word-diff=color" + ) + ) + +(define (diff s1 s2) + (let ((filename1 (call-with-tmpfile (lambda (p f) (pretty-print s1 p display?: #t) f))) + (filename2 (call-with-tmpfile (lambda (p f) (pretty-print s2 p display?: #t) f)))) + (let ((pipe (apply open-pipe* + OPEN_READ + (append diff-cmd (list filename1 filename2))))) + (begin1 (read-string pipe) + (close-pipe pipe))))) diff --git a/tests/run-tests.scm b/tests/run-tests.scm index f1ff7b03..d3ba53f8 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -20,11 +20,8 @@ fi (use-modules (srfi srfi-1) (srfi srfi-64) (srfi srfi-88) - (hnh util) ((hnh util io) :select (call-with-tmpfile)) - (ice-9 ftw) (ice-9 format) - (ice-9 pretty-print) (ice-9 getopt-long) (ice-9 match) (ice-9 regex) @@ -34,164 +31,12 @@ fi ((ice-9 rdelim) :select (read-string)) (system vm coverage) ((hnh module-introspection all-modules) :select (fs-find)) + + (hnh test testrunner) ) - -(define diff-cmd '("diff") - ;; '("git" "diff" "--no-index" "--word-diff=color") - ) - -(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 (string-replace-head s1 s2) - (string-replace s1 s2 - 0 (string-length s2))) - -(define (diff s1 s2) - (let ((filename1 (call-with-tmpfile (lambda (p f) (pretty-print s1 p display?: #t) f))) - (filename2 (call-with-tmpfile (lambda (p f) (pretty-print s2 p display?: #t) f)))) - (let ((pipe (apply open-pipe* - OPEN_READ - (append diff-cmd (list filename1 filename2))))) - (begin1 (read-string pipe) - (close-pipe pipe))))) - -(define (pp form indent prefix-1) - (let ((prefix (make-string (+ (string-length indent) - (string-length prefix-1)) - #\space))) - (string-replace-head - (with-output-to-string - (lambda () (pretty-print - form - per-line-prefix: prefix - width: (- 79 (string-length indent))))) - (string-append indent prefix-1)))) - - -(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) - (flush-all-ports) - (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))) - (let ((indent (make-indent (1+ depth)))) - (if (eq? expected unknown-expected) - (format #t "~aAssertion failed~%" indent) - (begin - (display (pp expected indent "Expected: ")) - (display (pp actual indent "Received: ")) - (let ((d (diff (pp expected "" "") - (pp actual "" "")))) - (display - (string-join - (map (lambda (line) (string-append indent "|" line)) - (string-split d #\newline)) - "\n" 'suffix)))))))))) - (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) |