tap: Rewrite so no tests fail because of tap
This commit is contained in:
parent
62296ec2d7
commit
4f71f50312
27
Makefile
27
Makefile
|
|
@ -2,7 +2,6 @@
|
|||
SCHEME=chibi
|
||||
RNRS=r7rs
|
||||
LIBRARY=tap
|
||||
DOCKER_TAG=latest
|
||||
|
||||
AUTHOR=retropikzel
|
||||
PKG=${AUTHOR}-${LIBRARY}-${VERSION}.tgz
|
||||
|
|
@ -12,32 +11,16 @@ LIBRARY_FILE=retropikzel/${LIBRARY}.sld
|
|||
TESTFILE=retropikzel/${LIBRARY}/test.scm
|
||||
VERSION != cat retropikzel/${LIBRARY}/VERSION
|
||||
DESCRIPTION != head -n1 retropikzel/${LIBRARY}/README.md
|
||||
DOCFILE=retropikzel/${LIBRARY}/README.html
|
||||
|
||||
ifeq "${SCHEME}" "capyscheme"
|
||||
DOCKER_TAG=head
|
||||
endif
|
||||
ifeq "${SCHEME}" "chibi"
|
||||
DOCKER_TAG=head
|
||||
endif
|
||||
ifeq "${SCHEME}" "chicken"
|
||||
DOCKER_TAG=head
|
||||
endif
|
||||
ifeq "${SCHEME}" "gauche"
|
||||
DOCKER_TAG=head
|
||||
endif
|
||||
|
||||
|
||||
|
||||
all: package
|
||||
|
||||
package: retropikzel/${LIBRARY}/LICENSE retropikzel/${LIBRARY}/VERSION retropikzel/${LIBRARY}/README.md
|
||||
echo "<pre>$$(cat retropikzel/${LIBRARY}/README.md)</pre>" > ${DOCFILE}
|
||||
echo "<pre>$$(cat retropikzel/${LIBRARY}/README.md)</pre>" > index.html
|
||||
snow-chibi package \
|
||||
--always-yes \
|
||||
--version=${VERSION} \
|
||||
--authors=${AUTHOR} \
|
||||
--doc=${DOCFILE} \
|
||||
--doc=index.html \
|
||||
--test=${TESTFILE} \
|
||||
--description="${DESCRIPTION}" \
|
||||
${LIBRARY_FILE}
|
||||
|
|
@ -49,8 +32,7 @@ install: ${PKG}
|
|||
--impls=${SCHEME} \
|
||||
--always-yes \
|
||||
--verbose?=1 \
|
||||
--install-tests?=1 \
|
||||
--show-tests?=1 \
|
||||
--skip-tests?=1 \
|
||||
${PKG}
|
||||
|
||||
test: package
|
||||
|
|
@ -61,10 +43,9 @@ test-compile-r7rs:
|
|||
./test-program
|
||||
|
||||
test-docker:
|
||||
SNOW_PACKAGES="srfi.19 srfi.64 srfi.180 retropikzel.tap ${PKG}" \
|
||||
SNOW_PACKAGES="srfi.64 retropikzel.tap ${PKG}" \
|
||||
APT_PACKAGES="libcurl4-openssl-dev" \
|
||||
AKKU_PACKAGES="${AKKU_PACKAGES}" \
|
||||
DOCKER_TAG=${DOCKER_TAG} \
|
||||
COMPILE_R7RS=${SCHEME} \
|
||||
CSC_OPIONS="-L -lcurl" \
|
||||
test-r7rs -o test-program ${TESTFILE}
|
||||
|
|
|
|||
|
|
@ -20,112 +20,152 @@
|
|||
|
||||
;;> \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-syntax tap-runner
|
||||
(syntax-rules ()
|
||||
((_)
|
||||
(letrec* ((any->string
|
||||
(lambda (any)
|
||||
(let ((port (open-output-string)))
|
||||
(display any port)
|
||||
(get-output-string port))))
|
||||
(indentation '())
|
||||
(increase-indentation
|
||||
(lambda ()
|
||||
(set! indentation (append indentation '(#\space #\space)))))
|
||||
(decrease-indentation
|
||||
(lambda ()
|
||||
(when (not (null? indentation))
|
||||
(set! indentation (list-tail indentation 2)))))
|
||||
(print
|
||||
(lambda args
|
||||
(map (lambda (item)
|
||||
(display item))
|
||||
(append indentation args))))
|
||||
(println
|
||||
(lambda args
|
||||
(map (lambda (item)
|
||||
(display item))
|
||||
(append indentation args))
|
||||
(display "\n")))
|
||||
(runner (test-runner-null))
|
||||
(started? #f)
|
||||
(current-test-groups (vector))
|
||||
(current-test-group-count 0)
|
||||
(current-suite-name #f)
|
||||
(exit-with-fail? #f))
|
||||
(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))
|
||||
|
||||
(test-runner-on-group-begin!
|
||||
runner
|
||||
(lambda (runner suite-name count)
|
||||
(when (not started?)
|
||||
(println "TAP version 14")
|
||||
(set! started? #t))
|
||||
(set! current-test-group-count 0)
|
||||
(when current-suite-name
|
||||
(println "# Subtest: " suite-name)
|
||||
(increase-indentation))
|
||||
(set! current-suite-name suite-name)
|
||||
(set! current-test-groups (vector-append current-test-groups (vector suite-name)))))
|
||||
(define (test-on-group-begin-tap runner name count)
|
||||
(cond ((null? (test-runner-group-stack runner))
|
||||
(display-map runner "TAP version 14" #\newline))
|
||||
(else
|
||||
(increase-group-test-count (car (test-runner-group-stack runner)))
|
||||
(display-map runner "# Subtest: " name #\newline))))
|
||||
|
||||
(test-runner-on-group-end!
|
||||
runner
|
||||
(lambda (runner)
|
||||
(when (> current-test-group-count 0)
|
||||
(println "1.." current-test-group-count))
|
||||
(decrease-indentation)
|
||||
(set! current-test-groups
|
||||
(list->vector
|
||||
(reverse
|
||||
(list-tail
|
||||
(reverse (vector->list current-test-groups))
|
||||
1))))))
|
||||
(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))))))
|
||||
|
||||
(test-runner-on-test-begin!
|
||||
runner
|
||||
(lambda (runner)
|
||||
(set! current-test-group-count (+ current-test-group-count 1))))
|
||||
(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)))
|
||||
|
||||
(test-runner-on-test-end!
|
||||
runner
|
||||
(lambda (runner)
|
||||
(let* ((name (test-runner-test-name runner))
|
||||
(result (test-result-kind runner))
|
||||
(status (cond ((equal? result 'pass) "passed")
|
||||
((equal? result 'xpass) "passed")
|
||||
((equal? result 'fail) "failed")
|
||||
((equal? result 'xfail) "failed")
|
||||
((equal? result 'skipped) "skipped")
|
||||
(else "other")))
|
||||
(result-ref
|
||||
(lambda (runner key)
|
||||
(let ((value (test-result-ref runner key)))
|
||||
(if value (any->string value) "")))))
|
||||
(let* ((failed? (or (equal? result 'fail) (equal? result 'xfail))))
|
||||
(cond (failed?
|
||||
(set! exit-with-fail? #t)
|
||||
(print "not ok " current-test-group-count))
|
||||
(else (print "ok " current-test-group-count)))
|
||||
(if (and (string? name) (not (string=? name "")))
|
||||
(println " - " name)
|
||||
(println ""))
|
||||
(when failed?
|
||||
(println " ---")
|
||||
(println " severity: fail")
|
||||
(println " data:")
|
||||
(println " source: " (result-ref runner 'source-form))
|
||||
(println " got: " (result-ref runner 'actual-value))
|
||||
(println " expect: " (result-ref runner 'expected-value))
|
||||
(println " at: ")
|
||||
(println " file: " (result-ref runner 'source-file))
|
||||
(println " line: " (result-ref runner 'source-line)))))))
|
||||
(define (test-on-test-begin-tap runner)
|
||||
(when (null? (test-runner-group-stack runner))
|
||||
(error "Running tests without test-begin"))
|
||||
(values))
|
||||
|
||||
(test-runner-on-final!
|
||||
runner
|
||||
(lambda (runner)
|
||||
(when (and (get-environment-variable "SCM_TAP_EXIT_FAIL")
|
||||
exit-with-fail?)
|
||||
(exit 1))))
|
||||
(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 (if (string=? (test-runner-test-name runner) "")
|
||||
""
|
||||
(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)
|
||||
(display-map runner " data:" #\newline)
|
||||
(display-map runner " source: " (test-result-ref runner 'source-form) #\newline)
|
||||
(display-map runner " got: " (test-result-ref runner 'actual-value) #\newline)
|
||||
(display-map runner " expect: " (test-result-ref runner 'expected-value) #\newline)
|
||||
(display-map runner " at: " #\newline)
|
||||
(display-map runner " file: " (test-result-ref runner 'source-file) #\newline)
|
||||
(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)))))
|
||||
|
||||
runner))))
|
||||
(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
|
||||
"\".")))
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(retropikzel tap)
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
(scheme file)
|
||||
(scheme process-context)
|
||||
(srfi 64))
|
||||
(export tap-runner)
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
0.4.0
|
||||
0.5.0
|
||||
|
|
|
|||
|
|
@ -1,27 +1,56 @@
|
|||
(import (scheme base)
|
||||
(scheme write)
|
||||
(retropikzel tap)
|
||||
(srfi 64))
|
||||
|
||||
(test-runner-current (tap-runner))
|
||||
|
||||
(test-begin "tap")
|
||||
(test-assert #t)
|
||||
(test-assert #t)
|
||||
(test-equal 1 1)
|
||||
(test-equal 1 1)
|
||||
|
||||
(test-begin "tap 1")
|
||||
(test-assert #t)
|
||||
(test-assert #t)
|
||||
;(test-assert #f)
|
||||
;(test-equal '(1 2 3) '(4 5 6))
|
||||
(test-equal 1 1)
|
||||
(test-equal 1 1)
|
||||
(test-end "tap 1")
|
||||
|
||||
(test-begin "tap 2")
|
||||
(test-equal '(1 2 3) '(1 2 3))
|
||||
(test-assert #t)
|
||||
(test-equal 1 1)
|
||||
(test-assert "I have a name" #t)
|
||||
|
||||
(test-begin "tap 2.1")
|
||||
(test-equal 1 1)
|
||||
|
||||
(test-begin "tap 2.1.1")
|
||||
(test-skip)
|
||||
(test-equal 1 1)
|
||||
(test-end "tap 2.1.1")
|
||||
|
||||
(test-end "tap 2.1")
|
||||
|
||||
(test-end "tap 2")
|
||||
|
||||
(test-assert #t)
|
||||
(test-equal 1 1)
|
||||
;(test-equal '(4 5 6) '(7 8 9))
|
||||
|
||||
|
||||
(test-skip (lambda (runner)
|
||||
(string=? (car (test-runner-group-stack runner)) "tap 3")))
|
||||
(test-begin "tap 3")
|
||||
(test-equal 1 1)
|
||||
(test-equal 1 1)
|
||||
(test-equal 1 1)
|
||||
(test-end "tap 3")
|
||||
|
||||
(test-group
|
||||
"tap 4"
|
||||
(test-assert (= 1 1))
|
||||
(test-assert (= 1 1))
|
||||
(test-assert (= 1 1))
|
||||
(test-assert (= 1 1))
|
||||
(test-assert (= 1 1))
|
||||
(test-assert (= 1 1)))
|
||||
|
||||
|
||||
(test-end "tap")
|
||||
|
|
|
|||
Loading…
Reference in New Issue