In the beginning there was darkness

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"))))

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))
+
+    ))