#| Copyright 2024 Peter McGoron
 |
 | Licensed under the Apache License, Version 2.0 (the "License");
 |
 | you may not use this file except in compliance with the License.
 | You may obtain a copy of the License at
 |
 |     http://www.apache.org/licenses/LICENSE-2.0
 |
 | Unless required by applicable law or agreed to in writing, software
 | distributed under the License is distributed on an "AS IS" BASIS,
 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 | See the License for the specific language governing permissions and
 | limitations under the License.
 |#

(define *global-make-displayable*
  ;; The list of default container objects that are traversed using
  ;; MAKE-DISPLAYABLE.
  (list
   (cons pair?
         (lambda (runner value)
           (cons (make-displayable runner (car value))
                 (make-displayable runner (cdr value)))))
   (cons vector?
         (lambda (runner value)
           (vector-map (lambda (value)
                         (make-displayable runner value))
                       value)))
   (cons eof-object?
         (lambda (_)
           `(an-eof-object)))))

(cond-expand
 (chicken
  (set! *global-make-displayable*
        ;; Handle chicken condition objects.
        (cons
         (cons condition?
               (lambda (runner value)
                 (make-displayable runner (condition->list value))))
         *global-make-displayable*)))
 (else))

(define set-displayable!
  (case-lambda
    ((predicate? transformer) (set-displayable! (test-runner-current)
                                                predicate?
                                                transformer))
    ((runner predicate? transformer)
     (let ((aux (test-runner-aux-value runner)))
       (%set-displayables! aux
                           (cons (cons predicate? transformer)
                                 (get-displayables aux)))))))

(define (make-displayable runner value)
  ;; Uses the DISPLAYABLES in RUNNER to transform VALUE into something
  ;; that is easier to print.
  (let loop ((lst (get-displayables (test-runner-aux-value runner))))
    (if (null? lst)
        value
        (let* ((pair (car lst))
               (predicate? (car pair))
               (transformer (cdr pair)))
          (if (predicate? value)
              (transformer runner value)
              (loop (cdr lst)))))))

(define-record-type <group-information>
  ;; Counts the number of tests passed or failed in a group (Because the
  ;; reference implementation does not do this).
  (group-information tests-passed-in-group
                     tests-failed-in-group
                     tests-skipped-in-group)
  group-information?
  (tests-passed-in-group get-tests-passed-in-group
                         set-tests-passed-in-group!)
  (tests-failed-in-group get-tests-failed-in-group
                         set-tests-failed-in-group!)
  (tests-skipped-in-group get-tests-skipped-in-group
                          set-tests-skipped-in-group!))

(define-record-type <aux>
  ;; Auxillary data stored in the test runner.
  ;; 
  ;; DISPLAYABLES is the list of display transformers. It is carried
  ;; through all tests.
  ;; 
  ;; GROUP-INFORMATION-QUEUE is a list consisting of all information about
  ;; tests passed and failed in a group. When an element is popped the
  ;; stats are added to the next-in-line.
  ;; 
  ;; DYNAMIC-PROPERTIES is a property alist that can be modified by the
  ;; testing program (test-result-set! only works in implementation or
  ;; in runner code). They are reset at the end of each test.
  ;; 
  ;; VERBOSITY is a symbol. If VERBOSITY is "fails", then only failures
  ;; are displayed. Otherwise all results are displayed.
  (aux group-information-queue
       displayables
       dynamic-properties
       verbosity)
  aux?
  (group-information-queue get-group-queue set-group-queue!)
  (displayables get-displayables %set-displayables!)
  (dynamic-properties get-dynamic-properties set-dynamic-properties!)
  (verbosity %get-verbosity %set-verbosity!))

(define (add-to-tests-in-group! op aux num)
  (define (getter op)
    (case op
      ((skipped) get-tests-skipped-in-group)
      ((passed) get-tests-passed-in-group)
      ((failed) get-tests-failed-in-group)
      (else (error "invalid getter" op))))
  (define (setter op)
    (case op
      ((skipped) set-tests-skipped-in-group!)
      ((passed) set-tests-passed-in-group!)
      ((failed) set-tests-failed-in-group!)
      (else (error "invalid setter" op))))
  (let ((queue (get-group-queue aux)))
    (when (not (null? queue))
      (let ((group (car queue))
            (set (setter op))
            (get (getter op)))
        (set group (+ num (get group)))))))

(define dynamic-property-set!
  (let ((dynamic-property-set!
         (lambda (runner property value)
           (let* ((aux (test-runner-aux-value runner))
                  (old (get-dynamic-properties aux)))
             (set-dynamic-properties! aux
                                      (cons (cons property value)
                                            old))))))
    (case-lambda
      ((property value) (dynamic-property-set! (test-runner-current)
                                               property
                                               value))
      ((runner property value) (dynamic-property-set! runner
                                                      property
                                                      value)))))

(define (get-verbosity runner)
  (%get-verbosity (test-runner-aux-value runner)))

(define (report-this-test? runner)
  (let ((verbosity (get-verbosity runner)))
    (if (test-passed? runner)
        (not (eq? verbosity 'fails))
        #t)))

(define set-verbosity!
  (case-lambda
    ((value) (set-verbosity! (test-runner-current) value))
    ((runner value)
     (%set-verbosity! (test-runner-aux-value runner) value))))

(define (wnl runner form)
  ;; Expand all forms with MAKE-DISPLAYABLE and pretty print FORM.
  (let ((form (make-displayable runner form)))
    (cond-expand
      (chicken (pretty-print form))
      (else (begin
              (write form)
              (newline))))))

(define (on-test-end runner)
  (let ((kind (test-result-kind runner))
        (aux (test-runner-aux-value runner)))
    (cond
      ((eq? kind 'skip)
       (add-to-tests-in-group! 'skipped aux 1))
      ((test-passed? runner)
       (add-to-tests-in-group! 'passed aux 1))
      (else
       (add-to-tests-in-group! 'failed aux 1)))
    (when (report-this-test? runner)
      (wnl runner
           `(test ,(test-runner-test-name runner)
                  (result ,kind)
                  (properties ,@(get-dynamic-properties aux)
                              ,@(test-result-alist runner)))))
    (set-dynamic-properties! aux '())))

(define (on-group-begin runner suite-name count)
  (let ((aux (test-runner-aux-value runner)))
    (set-group-queue! aux
                      (cons (group-information 0 0 0)
                            (get-group-queue aux))))
  (wnl runner `(start ,suite-name)))

(define (on-group-end runner)
  (let* ((aux (test-runner-aux-value runner))
         (current-group (car (get-group-queue aux)))
         (passed (get-tests-passed-in-group current-group))
         (failed (get-tests-failed-in-group current-group))
         (skipped (get-tests-skipped-in-group current-group)))
    (wnl runner
         `(end (passed ,passed)
               (failed ,failed)
               (skipped ,skipped)
               (tests ,(+ passed failed skipped))))
    (let ((next-group-queue (cdr (get-group-queue aux))))
      (set-group-queue! aux next-group-queue)
      (when (not (null? next-group-queue))
        (let ((next-group (car next-group-queue)))
          (add-to-tests-in-group! 'passed aux passed)
          (add-to-tests-in-group! 'skipped aux skipped)
          (add-to-tests-in-group! 'failed aux failed))))))

(define (on-bad-count runner actual expected)
  (wnl runner
       `(warning expected ,expected
                 got ,actual)))

(define (on-bad-end-name runner begin-name end-name)
  (error "mismatch in test names" begin-name end-name
         (test-runner-group-stack runner)
         runner))

(define (on-final runner)
  (wnl runner
       `(summary
         (pass (expected ,(test-runner-pass-count runner))
               (not-expected ,(test-runner-xpass-count runner)))
         (fail (not-expected ,(test-runner-fail-count runner))
               (expected ,(test-runner-xfail-count runner)))
         (skipped ,(test-runner-skip-count runner)))))

(define (factory)
  (let ((runner (test-runner-null)))
    (test-runner-aux-value! runner
                            (aux '() *global-make-displayable* '()
                                 'all))
    (test-runner-on-test-end! runner on-test-end)
    (test-runner-on-group-begin! runner on-group-begin)
    (test-runner-on-group-end! runner on-group-end)
    (test-runner-on-bad-end-name! runner on-bad-end-name)
    (test-runner-on-bad-count! runner on-bad-end-name)
    (test-runner-on-final! runner on-final)
    runner))