;;; ;;;;;;;;;;;;;;;;;;;
;;; Manipulating the test info
;;; ;;;;;;;;;;;;;;;;;;;

(define (modify-test-info! proc)
  (set-test-info! (test-info) (inspect-test-info proc)))

(define (inspect-test-info proc)
  (proc (test-info-dict)))

(define-syntax define-destructive-test-info-procedure
  (syntax-rules ()
    ((_ (name args ...) proc)
     (define (name args ...)
       (modify-test-info! (lambda (dictionary)
                            (proc (test-dto) dictionary args ...)))))
    ((_ (name . args) proc)
     (define (name . other-args)
       (modify-test-info! (lambda (dictionary)
                            (apply proc (test-dto)
                                   dictionary other-args)))))))

(define-syntax define-inspecting-test-info-procedure
  (syntax-rules ()
    ((_ (name args ...) proc)
     (define (name args ...)
       (inspect-test-info (lambda (dictionary)
                            (proc (test-dto)
                                  dictionary args ...)))))
    ((_ (name . args) proc)
     (define (name . other-args)
       (inspect-test-info (lambda (dictionary)
                            (apply proc (test-dto)
                                   dictionary other-args)))))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Mutating operations on the test info
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;

(define-destructive-test-info-procedure
    (test-set! . args) dict-set!)
(define-destructive-test-info-procedure
    (test-update! key updater . rest) dict-update!)
(define-destructive-test-info-procedure
    (test-update/default! key updater default) dict-update/default!)
(define-destructive-test-info-procedure
    (test-delete! . keys) dict-delete!)

(define-inspecting-test-info-procedure
    (test-contains? key) dict-contains?)
(define-inspecting-test-info-procedure
    (test-ref key . rest) dict-ref)
(define-inspecting-test-info-procedure
    (test-ref/default key default) dict-ref/default)
(define-inspecting-test-info-procedure
    (test-set . args) dict-set!)
(define-inspecting-test-info-procedure
    (test-update/default key value) dict-update/default!)

;;; ;;;;;;;;;;;;;;;;;;;;;;;;
;;; Manipulating the parameter object
;;; ;;;;;;;;;;;;;;;;;;;;;;;;

(define (call/hooks before! setup! cleanup! skip? when-skipped after
                    on-exception
                    name thunk)
  (define (body)
    ;; This escapes the exception handler before attempting to re-raise
    ;; the exception. This is to work around some bugs(?) in CHICKEN.
    (call/cc
     (lambda (return)
       (define (handler ex)
         (return (lambda ()
                   (call/cc
                    (lambda (return)
                      ((test-ref on-exception) ex (lambda () (return #f)))
                      (raise ex))))))
       (with-exception-handler handler thunk)
       (lambda () #f))))
  (define (exec)
    ((test-ref before!) name)
    (parameterize ((test-info (test-info-dict)))
      ((test-ref setup!) name)
      ((body))
      ((test-ref cleanup!) name)
      (test-info-dict)))
  (if ((test-ref skip?) name)
      ((test-ref when-skipped) name)
      ((test-ref after) (exec))))

(define (call-as-test name thunk)
  (call/hooks 'before-test!
              'setup-test!
              'cleanup-test!
              'skip-test?
              'when-test-skipped
              'after-test
              'on-exception-in-test
              name thunk))

(define (call-as-group name thunk)
  (call/hooks 'before-group!
              'setup-group!
              'cleanup-group!
              'skip-group?
              'when-group-skipped
              'after-group
              'on-exception-in-group
              name thunk))

(define (setup-name! name)
  (test-set! 'name name)
  (when name
    (test-update/default! 'name-stack
                          (lambda (x) (cons name x))
                          '())))

;;; ;;;;;;;;;;
;;; Default handlers for tests
;;; ;;;;;;;;;;

(define (default-skip-test? name) #f)
(define (default-before-test! name) #f)

(define (default-setup-test! name)
  (test-delete! 'success?)
  (setup-name! name))
(define (default-cleanup-test! name) #f)

(define (default-when-test-skipped name)
  (test-update/default! 'skipped
                        (lambda (x) (+ 1 x))
                        0)
  (test-update/default! 'tests
                        (lambda (x) (+ x 1))
                        0)
  (display (string-append "SKIP        " (if name
                                             (string-append "\"" name "\"")
                                             "test")
                          "\n")))

(define (default-after-test previous-test-info)
  (test-update/default! 'tests
                        (lambda (x) (+ x 1))
                        0)
  (let ((success? (dict-ref/default (test-dto)
                                    previous-test-info
                                    'success?
                                    #f)))
    (test-update/default! (if success? 'passed 'failed)
                          (lambda (x) (+ 1 x))
                          0)
    ((test-ref 'report-test) previous-test-info)))

(define (display-report previous-dict)
  (let ((never-print-dto (dict-ref (test-dto)
                                   previous-dict
                                   'never-print-dto))
        (never-print (dict-ref (test-dto)
                               previous-dict
                               'never-print)))
    (dict-for-each (test-dto)
                   (lambda (key value)
                     (unless (dict-contains? never-print-dto
                                             never-print
                                             key)
                       (pretty-print
                        (list (rewrite key)
                              (rewrite value)))))
                   previous-dict)))

(define (default-report-test previous-test-info)
  (let ((verbose? (test-ref/default 'verbose? #f))
        (specifically-verbose? (dict-ref/default (test-dto)
                                                 previous-test-info
                                                 'verbose?
                                                 #f))
        (success? (dict-ref/default (test-dto)
                                    previous-test-info
                                    'success?
                                    #f))
        (name (cond
                ((dict-ref (test-dto)
                           previous-test-info
                           'name))
                (else ""))))
    (cond
      (success?
       (when (or verbose? specifically-verbose?)
         (display (string-append "PASS:           \"" name "\"\n"))))
      (else
       (display (string-append "FAIL:           \"" name "\"\n"))
       (display-report previous-test-info)))
    previous-test-info))

(define (default-on-exception-in-test exn return)
  (test-set! 'success? #f 'exception exn)
  (return))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Default handlers for groups
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (default-skip-group? name) #f)
(define (default-when-group-skipped name)
  (display (string-append "SKIP GROUP      "
                          (if name
                              (string-append "\"" name "\"")
                              "")
                          "\n")))

(define (default-before-group! name)
  (when (test-ref/default 'verbose? #f)
    (display (string-append "ENTER    " (if name name "group") "\n"))))

(define (default-setup-group! name)
  (test-set! 'tests 0 'passed 0 'failed 0 'skipped 0)
  (setup-name! name))
(define (default-cleanup-group! name) #f)

(define (default-after-group previous-info)
  (define (update/previous! name)
    (test-update/default!
     name
     (lambda (x) (+ x (dict-ref/default (test-dto)
                                        previous-info
                                        name
                                        0)))
     0))
  (for-each update/previous! '(tests passed failed skipped))
  ((test-ref 'report-group) previous-info))

(define (default-report-group previous-info)
  (when (or (test-ref/default 'verbose? #f)
            (dict-ref/default (test-dto) previous-info
                              'verbose? #f))
    (cond
      ((dict-ref (test-dto) previous-info 'name)
       => (lambda (name)
            (display (string-append "EXIT \"" name "\"\n"))))
      (else (display "EXIT group\n"))))
  previous-info)

(define (default-on-exception-in-group ex return)
  (error 'on-exception-in-group
         "exception in group"
         (test-ref 'name-stack)
         (rewrite ex)))

;;; ;;;;;;;;;;;;;;;;
;;; test info
;;; ;;;;;;;;;;;;;;;;

(define default-test-info-dict
  (alist->default-dictionary
   `((skip-test? . ,default-skip-test?)
     (when-test-skipped . ,default-when-test-skipped)
     (before-test! . ,default-before-test!)
     (setup-test! . ,default-setup-test!)
     (cleanup-test! . ,default-cleanup-test!)
     (after-test . ,default-after-test)
     (report-test . ,default-report-test)
     (on-exception-in-test . ,default-on-exception-in-test)
     ;; groups
     (skip-group? . ,default-skip-group?)
     (when-group-skipped . ,default-when-group-skipped)
     (before-group! . ,default-before-group!)
     (setup-group! . ,default-setup-group!)
     (cleanup-group! . ,default-cleanup-group!)
     (after-group . ,default-after-group)
     (report-group . ,default-report-group)
     (on-exception-in-group . ,default-on-exception-in-group)
     (passed . 0)
     (failed . 0)
     (skipped . 0)
     (tests . 0)
     (name . #f)
     (name-stack . ())
     (never-print-dto . ,equal-alist-dto)
     (pretty-print . ,pretty-print)
     (never-print . ,(map (lambda (x) (cons x x))
                          '(skip-test? when-test-skipped before-test! setup-test!
                                       cleanup-test! after-test report-test
                                       on-exception-in-test
                                       skip-group? when-group-skipped before-group!
                                       setup-group! cleanup-group! after-group
                                       report-group on-exception-in-group
                                       never-print name rewriters
                                       never-print-dto pretty-print))))))

(define test-dto (make-parameter default-test-dto
                                 (lambda (x)
                                   (unless (dto? x)
                                     (assertion-violation 'test-dto
                                                          "must be a DTO"
                                                          x))
                                   x)))
(define test-info (make-parameter default-test-info-dict
                                  (lambda (x)
                                    (if (test-info? x)
                                        x
                                        (wrap-test-info x)))))
(define (test-info-dict) (unwrap-test-info (test-info)))

;;; ;;;;;;;;;;;;
;;; Wrappers and semi-compatability with SRFI-64
;;; ;;;;;;;;;;;;

(define-syntax test-application
  (syntax-rules ()
    ((_ test-name (name expr) ...)
     (call-as-test test-name (lambda ()
                               (test-set! 'form (quote (expr ...)))
                               (let ((name (let ((tmp expr))
                                             (test-set! (quote name) tmp)
                                             tmp))
                                     ...)
                                 (test-set! 'success? (name ...))))))))

(define-syntax test-body
  (syntax-rules ()
    ((_ name body ...)
     (call-as-test name (lambda ()
                          (test-set! 'success?
                                     (let () body ...)))))))

(define-syntax test-equal
  (syntax-rules ()
    ((_ name %expected %actual)
     (test-application name
                       (procedure equal?)
                       (expected %expected)
                       (actual %actual)))))

(define-syntax test-eqv
  (syntax-rules ()
    ((_ name %expected %actual)
     (test-application name
                       (procedure eqv?)
                       (expected %expected)
                       (actual %actual)))))


(define-syntax test-eq
  (syntax-rules ()
    ((_ name %expected %actual)
     (test-application name
                       (procedure eq?)
                       (expected %expected)
                       (actual %actual)))))

(define (%test-approximate expected actual error)
  (<= (abs (- expected actual)) error))

(define-syntax test-approximate
  (syntax-rules ()
    ((_ name %expected %actual %error)
     (test-application name
                       (procedure %test-approximate)
                       (expected %expected)
                       (actual %actual)
                       (error %error)))))

(define-syntax test-error
  (syntax-rules ()
    ((_ name error-predicate body ...)
     (test-body name
       (let ((p error-predicate))
         (test-set! 'on-exception-in-test
                    (lambda (ex return)
                      (test-set! 'success? (p ex))
                      (return))))
       (let () body ...)
       #f))))

(define-syntax expect-to-fail
  (syntax-rules ()
    ((_ body ...)
     (let ((outer-after-test (test-ref 'after-test)))
       (test-group #f
         (test-set! 'after-test
                    (lambda (dict)
                      (outer-after-test (dict-update! (test-dto) dict
                                                      'success?
                                                      not))))
         (let () body ...))))))

(define-syntax test-skip-all
  (syntax-rules ()
    ((_ body ...)
     (test-group #f
       (test-set! 'skip-test? (lambda (_) #t))
       (let () body ...)))))

(define-syntax test-group
  (syntax-rules ()
    ((_ name body ...)
     (call-as-group name (lambda () body ...)))))

(define-syntax with-test-group-cleanup
  (syntax-rules ()
    ((_ name body ... cleanup-expr)
     (test-group name
       (dynamic-wind
        (lambda () #f)
        (lambda () body ...)
        (lambda () cleanup-expr))))))

(define (test-exit)
  (display "==== EXITING TEST SUITE =====\n")
  (call-with-values (lambda () (inspect-test-info values))
    display-report)
  (exit (if (zero? (test-ref/default 'failed 0))
            0
            1)))