;;> \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
                        "\".")))