tap: Rewrite so no tests fail because of tap

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 \
+		--skip-tests?=1 \
-		--show-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}

retropikzel/tap.scm

@@ -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
+(define (tap-runner)
-  (syntax-rules ()
+  (let ((runner (test-runner-null)))
-    ((_)
+    (test-runner-reset runner)
-     (letrec* ((any->string
+    (test-runner-on-group-begin!     runner test-on-group-begin-tap)
-                 (lambda (any)
+    (test-runner-on-group-end!       runner test-on-group-end-tap)
-                   (let ((port (open-output-string)))
+    (test-runner-on-final!           runner test-on-final-tap)
-                     (display any port)
+    (test-runner-on-test-begin!      runner test-on-test-begin-tap)
-                     (get-output-string port))))
+    (test-runner-on-test-end!        runner test-on-test-end-tap)
-               (indentation '())
+    (test-runner-on-bad-count!       runner test-on-bad-count-tap)
-               (increase-indentation
+    (test-runner-on-bad-end-name!    runner test-on-bad-end-name-tap)
-                 (lambda ()
+    runner))
-                   (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))
 
-       (test-runner-on-group-begin!
+(define (test-on-group-begin-tap runner name count)
-         runner
+  (cond ((null? (test-runner-group-stack runner))
-         (lambda (runner suite-name count)
+         (display-map runner "TAP version 14" #\newline))
-           (when (not started?)
+        (else
-             (println "TAP version 14")
+          (increase-group-test-count (car (test-runner-group-stack runner)))
-             (set! started? #t))
+          (display-map runner "# Subtest: " name #\newline))))
-           (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)))))
 
-       (test-runner-on-group-end!
+(define (test-on-group-end-tap runner)
-         runner
+  (let ((count (cdr (or (assoc (car (test-runner-group-stack runner))
-         (lambda (runner)
+                               group-test-counts)
-           (when (> current-test-group-count 0)
+                        (cons 0 0)))))
-             (println "1.." current-test-group-count))
+    (display-map runner "1.." (if (= count 0) "0 # skip" count) #\newline))
-           (decrease-indentation)
+  (when (> (length (test-runner-group-stack runner)) 1)
-           (set! current-test-groups
+    (let ((previous-count (cdr (or (assoc (cadr (test-runner-group-stack runner))
-             (list->vector
+                                          group-test-counts)
-               (reverse
+                                   (cons 0 0)))))
-                 (list-tail
+      (cond ((assoc (car (test-runner-group-stack runner)) group-fail-counts)
-                   (reverse (vector->list current-test-groups))
+             (display-map-1 runner "not ok " previous-count #\newline))
-                   1))))))
+            (else (display-map-1 runner "ok " previous-count #\newline))))))
 
-       (test-runner-on-test-begin!
+(define (test-on-final-tap runner)
-         runner
+  (display-map runner
-         (lambda (runner)
+               "# of total tests          "
-           (set! current-test-group-count (+ current-test-group-count 1))))
+               (+ (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!
+(define (test-on-test-begin-tap runner)
-         runner
+  (when (null? (test-runner-group-stack runner))
-         (lambda (runner)
+    (error "Running tests without test-begin"))
-           (let* ((name (test-runner-test-name runner))
+  (values))
-                  (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)))))))
 
-       (test-runner-on-final!
+(define (test-on-test-end-tap runner)
-         runner
+  (increase-group-test-count (car (test-runner-group-stack runner)))
-         (lambda (runner)
+  (let* ((result-kind-name (case (test-result-kind runner)
-           (when (and (get-environment-variable "SCM_TAP_EXIT_FAIL")
+                             ((pass) "pass")
-                      exit-with-fail?)
+                             ((fail) "fail")
-             (exit 1))))
+                             ((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
+                        "\".")))

retropikzel/tap.sld

@@ -2,6 +2,7 @@
   (retropikzel tap)
   (import (scheme base)
           (scheme write)
+          (scheme file)
           (scheme process-context)
           (srfi 64))
   (export tap-runner)

retropikzel/tap/VERSION

@@ -1 +1 @@
-0.4.0
+0.5.0

retropikzel/tap/test.scm

@@ -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-equal 1 1)
-(test-assert #t)
+(test-equal 1 1)
 
 (test-begin "tap 1")
-(test-assert #t)
+(test-equal 1 1)
-(test-assert #t)
+(test-equal 1 1)
-;(test-assert #f)
-;(test-equal '(1 2 3) '(4 5 6))
 (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")