185 lines
7.5 KiB
Scheme
185 lines
7.5 KiB
Scheme
;;> \pre{
|
|
;;> TAP output for SRFI-64
|
|
;;>
|
|
;;> [Test Anything Protocol](https://testanything.org/)
|
|
;;>
|
|
;;>}
|
|
|
|
;;> \section{Usage}
|
|
;;> \pre{
|
|
;;> (import (scheme base)
|
|
;;> (srfi 64)
|
|
;;> (retropikzel tap))
|
|
;;>
|
|
;;> (test-runner-current (tap-runner))
|
|
;;>
|
|
;;> (test-begin "My Cool Library")
|
|
;;> (test-equal 1 1)
|
|
;;> (test-end "My Cool Library")
|
|
;;>}
|
|
|
|
;;> \section{Reference}
|
|
|
|
(define group-test-counts '())
|
|
(define (increase-group-test-count name)
|
|
(set! group-test-counts
|
|
(cons (cons name
|
|
(+ (cdr (or (assoc name group-test-counts) (cons 0 0))) 1))
|
|
group-test-counts)))
|
|
|
|
(define group-fail-counts '())
|
|
(define (increase-group-fail-count name)
|
|
(set! group-fail-counts
|
|
(cons (cons name
|
|
(+ (cdr (or (assoc name group-fail-counts) (cons 0 0))) 1))
|
|
group-fail-counts)))
|
|
|
|
(define (display-map runner . args)
|
|
;; Indentation
|
|
(for-each
|
|
(lambda (group)
|
|
(display " "))
|
|
(if (> (length (test-runner-group-stack runner)) 1)
|
|
(cdr (test-runner-group-stack runner))
|
|
'()))
|
|
(map (lambda (item) (display item)) args))
|
|
|
|
(define (display-map-1 runner . args)
|
|
;; Indentation, -1
|
|
(for-each
|
|
(lambda (group)
|
|
(display " "))
|
|
(if (> (length (test-runner-group-stack runner)) 2)
|
|
(cdr (cdr (test-runner-group-stack runner)))
|
|
'()))
|
|
(map (lambda (item) (display item)) args))
|
|
|
|
;;>Get the TAP test runner.
|
|
(define (tap-runner)
|
|
(let ((runner (test-runner-null)))
|
|
(test-runner-reset runner)
|
|
(test-runner-on-group-begin! runner test-on-group-begin-tap)
|
|
(test-runner-on-group-end! runner test-on-group-end-tap)
|
|
(test-runner-on-final! runner test-on-final-tap)
|
|
(test-runner-on-test-begin! runner test-on-test-begin-tap)
|
|
(test-runner-on-test-end! runner test-on-test-end-tap)
|
|
(test-runner-on-bad-count! runner test-on-bad-count-tap)
|
|
(test-runner-on-bad-end-name! runner test-on-bad-end-name-tap)
|
|
runner))
|
|
|
|
(define (test-on-group-begin-tap runner name count)
|
|
(cond ((null? (test-runner-group-stack runner))
|
|
(display-map runner "TAP version 14" #\newline)
|
|
(display-map runner "# %%%% Starting test srfi-64" #\newline)
|
|
(when (implementation-name)
|
|
(display-map runner "# scheme: " (implementation-name) #\newline))
|
|
(when (implementation-version)
|
|
(display-map runner "# scheme version: " (implementation-version) #\newline))
|
|
(display-map runner "# scheme features: " (features) #\newline)
|
|
(when (cpu-architecture)
|
|
(display-map runner "# cpu-architecture: " (cpu-architecture) #\newline))
|
|
(when (machine-name)
|
|
(display-map runner "# machine-name: " (machine-name) #\newline)))
|
|
(else
|
|
(increase-group-test-count (car (test-runner-group-stack runner)))
|
|
(display-map runner "# Subtest: " name #\newline))))
|
|
|
|
(define (test-on-group-end-tap runner)
|
|
(let ((count (cdr (or (assoc (car (test-runner-group-stack runner))
|
|
group-test-counts)
|
|
(cons 0 0)))))
|
|
(display-map runner "1.." (if (= count 0) "0 # skip" count) #\newline))
|
|
(when (> (length (test-runner-group-stack runner)) 1)
|
|
(let ((previous-count (cdr (or (assoc (cadr (test-runner-group-stack runner))
|
|
group-test-counts)
|
|
(cons 0 0)))))
|
|
(cond ((assoc (car (test-runner-group-stack runner)) group-fail-counts)
|
|
(display-map-1 runner "not ok " previous-count #\newline))
|
|
(else (display-map-1 runner "ok " previous-count #\newline))))))
|
|
|
|
(define (test-on-final-tap runner)
|
|
(display-map runner
|
|
"# of total tests "
|
|
(+ (test-runner-pass-count runner)
|
|
(test-runner-xfail-count runner)
|
|
(test-runner-xpass-count runner)
|
|
(test-runner-fail-count runner)
|
|
(test-runner-skip-count runner))
|
|
#\newline)
|
|
(when (> (test-runner-pass-count runner) 0)
|
|
(display-map runner
|
|
"# of expected passes "
|
|
(test-runner-pass-count runner)
|
|
#\newline))
|
|
(when (> (test-runner-xfail-count runner) 0)
|
|
(display-map runner
|
|
"# of expected failures "
|
|
(test-runner-xfail-count runner)
|
|
#\newline))
|
|
(when (> (test-runner-xpass-count runner) 0)
|
|
(display-map runner
|
|
"# of unexpected successes "
|
|
(test-runner-xpass-count runner)
|
|
#\newline))
|
|
(when (> (test-runner-fail-count runner) 0)
|
|
(display-map runner
|
|
"# of failures "
|
|
(test-runner-fail-count runner)
|
|
#\newline))
|
|
(when (> (test-runner-skip-count runner) 0)
|
|
(display-map runner
|
|
"# of skipped test "
|
|
(test-runner-skip-count runner)
|
|
#\newline))
|
|
(when (and (not (get-environment-variable "SCM_TAP_NO_EXIT_FAIL"))
|
|
(> (test-runner-fail-count runner) 0))
|
|
(exit 1)))
|
|
|
|
(define (test-on-test-begin-tap runner)
|
|
(when (null? (test-runner-group-stack runner))
|
|
(error "Running tests without test-begin"))
|
|
(values))
|
|
|
|
(define (test-on-test-end-tap runner)
|
|
(increase-group-test-count (car (test-runner-group-stack runner)))
|
|
(let* ((result-kind-name (case (test-result-kind runner)
|
|
((pass) "pass")
|
|
((fail) "fail")
|
|
((xpass) "xpass")
|
|
((xfail) "xfail")
|
|
((skip) "skip")
|
|
(else "other")))
|
|
(count (cdr (assoc (car (test-runner-group-stack runner))
|
|
group-test-counts)))
|
|
(name
|
|
(cond ((not (string? (test-runner-test-name runner))) "")
|
|
((string=? (test-runner-test-name runner) "") "")
|
|
(else (string-append " - " (test-runner-test-name runner))))))
|
|
(cond ((equal? result-kind-name "fail")
|
|
(increase-group-fail-count (car (test-runner-group-stack runner)))
|
|
(display-map runner "not ok " count name #\newline)
|
|
(display-map runner " ---" #\newline)
|
|
(display-map runner " severity: fail" #\newline)
|
|
(when (test-result-ref runner 'source-form)
|
|
(display-map runner " source: " (test-result-ref runner 'source-form) #\newline))
|
|
(when (test-result-ref runner 'actual-value)
|
|
(display-map runner " got: " (test-result-ref runner 'actual-value) #\newline))
|
|
(when (test-result-ref runner 'expected-value)
|
|
(display-map runner " expect: " (test-result-ref runner 'expected-value) #\newline))
|
|
(when (test-result-ref runner 'source-file)
|
|
(display-map runner " file: " (test-result-ref runner 'source-file) #\newline))
|
|
(when (test-result-ref runner 'source-line)
|
|
(display-map runner " line: " (test-result-ref runner 'source-line) #\newline)))
|
|
((equal? result-kind-name "skip")
|
|
(display-map runner "ok " count name " # skip " #\newline))
|
|
(else (display-map runner "ok " count name #\newline)))))
|
|
|
|
(define (test-on-bad-count-tap runner count expected-count) #t)
|
|
|
|
(define (test-on-bad-end-name-tap runner begin-name end-name)
|
|
(error (string-append "Test-end \""
|
|
end-name
|
|
"\" does not match test-begin \""
|
|
begin-name
|
|
"\".")))
|