diff --git a/tap-srfi-64.egg b/tap-srfi-64.egg index 4a9b225..62eb02a 100644 --- a/tap-srfi-64.egg +++ b/tap-srfi-64.egg @@ -7,5 +7,5 @@ (dependencies r7rs srfi-64 srfi-152 srfi-197) (components - (extension tap-srfi-64 + (extension tap.srfi.64 (csc-options "-X" "r7rs" "-R" "r7rs" "-sJ")))) diff --git a/tap.srfi.64.scm b/tap.srfi.64.scm new file mode 100644 index 0000000..841788d --- /dev/null +++ b/tap.srfi.64.scm @@ -0,0 +1,83 @@ +(define-library (tap srfi 64) + (import (r7rs) + (chicken base) + (srfi 1) + (srfi 64) + (srfi 152) + (srfi 197)) + (export tap-test-runner) + (begin + + (define (test-name runner) + (string-append + (string-join (test-runner-group-path runner) " - ") + ;; " - " (test-runner-test-name runner) + )) + + (define (al-ref alist key) + (chain (let ((al-var (assq key alist))) + (if al-var + (cdr al-var) + "#f")) + (string-split _ "\n") + (string-join _ "\n "))) + + (define (tap-test-runner) + (let ((runner (test-runner-null)) + (testcounter 0)) + (print "TAP version 14\n") + (test-runner-on-test-end! runner + (lambda (runner) + (set! testcounter (+ testcounter 1)) + (let ((result (test-result-alist runner))) + (case (cdr (assq 'result-kind result)) + ('pass (print + (string-append + "ok " (number->string testcounter) " - " + (test-name runner)))) + ('fail (print + (string-append + "not ok " (number->string testcounter) " - " + (test-name runner) "\n" + " ---\n" + " message: The test failed, but was expected to pass. \n" + " severity: fail\n" + " data:\n" + " got: |\n " + (al-ref result 'actual-value) "\n" + " expect: |\n " + (al-ref result 'expected-value) "\n" + " at:\n" + " file: " (al-ref result 'source-file) "\n" + " line: " (al-ref result 'source-line) "\n" + " ..."))) + ('xfail (print + (string-append + "ok " (number->string testcounter) " - " + (test-name runner)))) + ('xpass (print + (string-append + "not ok " (number->string testcounter) " - " + (test-name runner) "\n" + " ---\n" + " message: The test passed, but was expected to fail. \n" + " severity: fail\n" + " data:\n" + " got: |\n " + (al-ref result 'actual-error) "\n" + " expect: |\n " + (al-ref result 'expected-error) "\n" + " at:\n" + " file: " (al-ref result 'source-file) "\n" + " line: " (al-ref result 'source-line) "\n" + " ...\n"))) + ('skip (print + (string-append + "ok " (number->string testcounter) " - " + (test-name runner) " # SKIP"))))))) + (test-runner-on-final! runner + (lambda (runner) + (print (string-append "1.." (number->string testcounter) "\n")))) + runner)) + + ))