;;;
;;; Copyright (c) 2006 OOHASHI Daichi, All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; 1. Redistributions of source code must retain the above copyright
;;;    notice, this list of conditions and the following disclaimer.
;;;
;;; 2. Redistributions in binary form must reproduce the above copyright
;;;    notice, this list of conditions and the following disclaimer in the
;;;    documentation and/or other materials provided with the distribution.
;;;
;;; 3. Neither the name of the authors nor the names of its contributors
;;;    may be used to endorse or promote products derived from this
;;;    software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;

(define-module srfi-64
  (use srfi-1)
  (use srfi-13)
  (use gauche.parameter)
  (use util.list)
  (export test-assert test-eqv test-equal test-eq test-approximate test-error
	  test-read-eval-string
	  test-begin test-end test-group test-group-with-cleanup
	  test-skip test-expect-fail
	  test-match-name test-match-nth test-match-any test-match-all

	  test-runner?
	  test-runner-current test-runner-get
	  test-runner-null test-runner-simple
	  test-runner-create test-runner-factory
	  test-with-runner test-apply

	  test-result-kind test-passed?
	  test-result-ref test-result-set!
	  test-result-remove test-result-clear

	  test-runner-on-test-begin test-runner-on-test-begin!
	  test-runner-on-test-end test-runner-on-test-end!
	  test-runner-on-group-begin test-runner-on-group-begin!
	  test-runner-on-group-end test-runner-on-group-end!
	  test-runner-on-bad-count test-runner-on-bad-count!
	  test-runner-on-bad-end-name test-runner-on-bad-end-name!
	  test-runner-on-final test-runner-on-final!
	  test-runner-pass-count test-runner-fail-count
	  test-runner-xpass-count test-runner-xfail-count

	  test-on-test-begin-simple test-on-test-end-simple
	  test-on-group-begin-simple test-on-group-end-simple
	  test-on-bad-count-simple test-on-bad-end-name-simple
	  test-on-final-simple

	  test-runner-skip-count
	  test-runner-test-name
	  test-runner-group-path test-runner-group-stack
	  test-runner-aux-value test-runner-aux-value!
	  test-result-alist

	  test-runner-reset))

(select-module srfi-64)

;;; Simple test-cases

(define-syntax test-assert
  (syntax-rules ()
    ((_ name expr)
     (test-comp boolean-equal? name #t expr))
    ((_ expr)
     (test-comp boolean-equal? "" #t expr))))

(define-syntax test-eqv
  (syntax-rules ()
    ((_ name exp expr)
     (test-comp eqv? name exp expr))
    ((_ exp expr)
     (test-comp eqv? "" exp expr))))

(define-syntax test-equal
  (syntax-rules ()
    ((_ name exp expr)
     (test-comp equal? name exp expr))
    ((_ exp expr)
     (test-comp equal? "" exp expr))))

(define-syntax test-eq
  (syntax-rules ()
    ((_ name exp expr)
     (test-comp eq? name exp expr))
    ((_ exp expr)
     (test-comp eq? "" exp expr))))

(define-syntax test-approximate
  (syntax-rules ()
    ((_ name exp expr err)
     (test-comp (nearly=?? err) name exp expr))
    ((_ exp expr err)
     (test-comp (nearly=?? err) "" exp expr))))


;;; test for catching errors

(define-syntax test-error
  (syntax-rules ()
    ((_ name err-type expr)
     (test-comp err-equal? name err-type expr))
    ((_ err-type expr)
     (test-comp err-equal? "" err-type expr))
    ((_ expr)
     (test-comp err-equal? "" #t expr))))


;;; Testing syntax

(define (test-read-eval-string str)
  (call-with-input-string str
    (lambda (port)
      (let1 form (read port)
	(if (eof-object? (read-char port))
	    (eval form)
	    (error "not at eof"))))))


;;; Test groups and paths

(define (test-begin name . opt)
  (unless (test-runner-current)
    (test-runner-current (test-runner-create)))
  (let ((count (get-optional opt #f))
	(runner (test-runner-get)))
    ((test-runner-on-group-begin runner) runner name count)
    (push! (ref runner 'skip-save) (ref runner 'skip-list))
    (push! (ref runner 'fail-save) (ref runner 'fail-list))
    (push! (ref runner 'count-list) (cons (ref runner 'total-count) count))
    (push! (ref runner 'group-stack) name)))

(define (test-end . opt)
  (let* ((name (get-optional opt #f))
	 (runner (test-runner-get))
	 (stack (test-runner-group-stack runner)))
    (cond
     ((null? stack)
      (error "extra test-end"))
     ((and name (not (string=? (car stack) name)))
      ((test-runner-on-bad-end-name runner) runner (car stack) name))
     (else
      (let* ((cts (pop! (ref runner 'count-list)))
	     (saved-count (car cts))
	     (expected-count (cdr cts))
	     (actual-count (- (ref runner 'total-count) saved-count)))
	(when (and expected-count
		   (not (= expected-count actual-count)))
	  ((test-runner-on-bad-count runner) runner actual-count expected-count))
	((test-runner-on-group-end runner) runner)
	(set! (ref runner 'skip-list) (pop! (ref runner 'skip-save)))
	(set! (ref runner 'fail-list) (pop! (ref runner 'fail-save)))
	(pop! (ref runner 'group-stack))
	(when (null? (test-runner-group-stack runner))
	  ((test-runner-on-final runner) runner)))))))

(define-syntax test-group
  (syntax-rules ()
    ((_ suite-name expr ...)
     (let ((name suite-name)
	   (runner (test-runner-get)))
       (set! (ref runner 'test-name) name)
       (unless (test-should-skip? runner)
	 (dynamic-wind
	     (lambda () (test-begin name))
	     (lambda () expr ...)
	     (lambda () (test-end name))))))))


;;; Handling set-up and cleanup

(define-syntax test-group-with-cleanup
  (syntax-rules ()
    ((_ name form cleanup)
     (test-group name
		 (dynamic-wind
		     (lambda () #f)
		     (lambda () form)
		     (lambda () cleanup))))
    ((_ name cleanup)
     (test-group-with-cleanup name #f cleanup))
    ((_ name form1 form2 form3 ...)
     (test-group-with-cleanup name (begin form1 form2) form3 ...))))


;;; Test specifiers

(define (test-match-name name)
  (lambda (runner)
    (equal? (test-runner-test-name runner) name)))

(define (test-match-nth n . opt)
  (let ((i 0)
	(count (get-optional opt 1)))
    (lambda (runner)
      (inc! i)
      (and (<= n i) (< i (+ n count))))))

(define (test-match-any . specs)
  (let1 sps (map x->specifier specs)
    (lambda (runner)
      (fold (lambda (spec res)
	      (or (spec runner) res))
	    #f sps))))

(define (test-match-all . specs)
  (let1 sps (map x->specifier specs)
    (lambda (runner)
      (fold (lambda (spec res)
	      (and (spec runner) res))
	    #t sps))))


;;; Skipping selected tests

(define (test-skip . specs)
  (push! (ref (test-runner-get) 'skip-list)
	 (apply test-match-all specs)))


;;; Expected failures

(define (test-expect-fail . specs)
  (push! (ref (test-runner-get) 'fail-list)
	 (apply test-match-all specs)))


;;;; Test-runner
(define-class <test-runner> ()
  ((on-test-begin-function
    :init-keyword :on-test-begin-function
    :getter test-runner-on-test-begin
    :setter test-runner-on-test-begin!)
   (on-test-end-function
    :init-keyword :on-test-end-function
    :getter test-runner-on-test-end
    :setter test-runner-on-test-end!)
   (on-group-begin-function
    :init-keyword :on-group-begin-function
    :getter test-runner-on-group-begin
   :setter test-runner-on-group-begin!)
   (on-group-end-function
    :init-keyword :on-group-end-function
    :getter test-runner-on-group-end
    :setter test-runner-on-group-end!)
   (on-bad-count-function
    :init-keyword :on-bad-count-function
    :getter test-runner-on-bad-count
    :setter test-runner-on-bad-count!)
   (on-bad-end-name-function
    :init-keyword :on-bad-end-name-function
    :getter test-runner-on-bad-end-name
    :setter test-runner-on-bad-end-name!)
   (on-final-function
    :init-keyword :on-final-function
    :getter test-runner-on-final
    :setter test-runner-on-final!)
   (pass-count
    :getter test-runner-pass-count
    :init-value 0)
   (fail-count
    :getter test-runner-fail-count
    :init-value 0)
   (xpass-count
    :getter test-runner-xpass-count
    :init-value 0)
   (xfail-count
    :getter test-runner-xfail-count
    :init-value 0)
   (skip-count
    :getter test-runner-skip-count
    :init-value 0)
   (test-name
    :getter test-runner-test-name
    :init-value "")
   (group-path
    :allocation :virtual
    :getter test-runner-group-path
    :slot-ref (lambda (self)
		(reverse (test-runner-group-stack self))))
   (group-stack
    :getter test-runner-group-stack
    :init-value '())
   (aux-value
    :getter test-runner-aux-value
    :setter test-runner-aux-value!)
   (result-alist
    :getter test-result-alist
    :init-value '())
   (skip-list
    :init-value '())
   (fail-list
    :init-value '())
   (run-specifier
    :init-value #f)
   (skip-save
    :init-value '())
   (fail-save
    :init-value '())
   (count-list
    :init-value '())
   (total-count
    :init-value 0)
   ))

(define (test-runner? obj)
  (is-a? obj <test-runner>))

(define test-runner-current (make-parameter #f))

(define (test-runner-get)
  (or (test-runner-current)
      (error "test-runner not initialized - test-begin missing?")))

(define (test-runner-simple)
  (make <test-runner>
    :on-group-begin-function test-on-group-begin-simple
    :on-group-end-function test-on-group-end-simple
    :on-final-function test-on-final-simple
    :on-test-begin-function test-on-test-begin-simple
    :on-test-end-function test-on-test-end-simple
    :on-bad-end-name-function test-on-bad-end-name-simple
    :on-bad-count-function test-on-bad-count-simple))

(define (test-runner-null)
  (make <test-runner>
    :on-group-begin-function (lambda (runner name count) #f)
    :on-group-end-function (lambda (runner) #f)
    :on-final-function (lambda (runner) #f)
    :on-test-begin-function (lambda (runner) #f)
    :on-test-end-function (lambda (runner) #f)
    :on-bad-count-function (lambda (runner count expected) #f)
    :on-bad-end-name-function (lambda (runner beg end) #f)))

(define (test-runner-create)
  ((test-runner-factory)))

(define test-runner-factory (make-parameter test-runner-simple))


;;; Running specific tests with a specified runner

(define-syntax test-with-runner
  (syntax-rules ()
    ((_ runner body ...)
     (parameterize ((test-runner-current runner))
       body ...))))

(define (test-apply head . rest)
  (cond ((test-runner? head)
	 (test-with-runner head (apply test-apply rest)))
	((not (test-runner-current))
	 (let1 runner (test-runner-create)
	   (test-with-runner runner (apply test-apply head rest))
	   ((test-runner-on-final runner) runner)))
	(else
	 (receive (thunk rspecs) (car+cdr (reverse! (cons head rest)))
	   (let* ((runner (test-runner-current)))
	     (set! (ref runner 'run-specifier)
		   (apply test-match-any (reverse! rspecs)))
	     (thunk)
	     (set! (ref runner 'run-specifier) #f))))))


;;;; Test result
;;; Result kind

(define (test-result-kind . opt)
  (let1 runner (get-optional opt (test-runner-current))
    (test-result-ref runner 'result-kind)))

(define (test-passed? . opt)
  (let1 kind (apply test-result-kind opt)
    (memq kind '(pass xpass))))


;;; Test result properties

(define (test-result-ref runner pname . opt)
  (apply assq-ref (test-result-alist runner) pname opt))

(define (test-result-set! runner pname value)
  (set! (ref runner 'result-alist)
	(assq-set! (test-result-alist runner) pname value)))

(define (test-result-remove runner pname)
  (set! (ref runner 'result-alist)
	(remove! (lambda (pair)
		   (eq? (car pair) pname))
		 (test-result-alist runner))))

(define (test-result-clear runner)
  (set! (ref runner 'result-alist) '()))


;;; Default call-back functions for test-runner-simple

(define (test-on-test-begin-simple runner)
  #f)

(define (test-on-test-end-simple runner)
  (let ((kind (test-result-kind runner)))
    (case kind
      ((fail)
       (format #t "~Afail: ~,,,,40:A~% ~,,,,77:S~%   expects ~S~%   but got ~S~%"
	       (test-runner-test-pos runner)
	       (test-runner-test-name runner)
	       (test-result-ref runner 'source-form)
	       (or (test-result-ref runner 'expected-value)
		   (test-result-ref runner 'expected-error))
	       (or (test-result-ref runner 'actual-value)
		   (test-result-ref runner 'actual-error))))
      ((xpass xfail skip)
       (format #t "~A~A: ~,,,,40:A~%"
	       (test-runner-test-pos runner)
	       kind
	       (test-runner-test-name runner))))))

(define (test-on-group-begin-simple runner suite-name count)
  #f)

(define (test-on-group-end-simple runner)
  #f)

(define (test-on-final-simple runner)
  (define (f fmt count)
    (when (positive? count)
      (format #t fmt count)))
  (f "# of unexpected failures:   ~2@A~%" (test-runner-fail-count runner))
  (f "# of unexpected passes:   ~2@A~%" (test-runner-xpass-count runner)))

(define (test-on-bad-count-simple runner actual expected)
  (errorf "Total number of tests should be ~A, but was ~A." expected actual))

(define (test-on-bad-end-name-simple runner begin-name end-name)
  (errorf "~A (test-end ~S) does not match (test-begin ~S)"
	  (test-runner-test-pos runner) end-name begin-name))


;;; Test-runner components

(define (test-runner-reset runner)
  (set! (ref runner 'pass-count) 0)
  (set! (ref runner 'fail-count) 0)
  (set! (ref runner 'xpass-count) 0)
  (set! (ref runner 'xfail-count) 0)
  (set! (ref runner 'skip-count) 0)
  (set! (ref runner 'total-count) 0)
  (set! (ref runner 'group-stack) '())
  (set! (ref runner 'skip-list) '())
  (set! (ref runner 'fail-list) '())
  (set! (ref runner 'skip-save) '())
  (set! (ref runner 'fail-save) '())
  (set! (ref runner 'count-list) '())
  (set! (ref runner 'run-specifier) #f))


;;; internal utilities

(define (test-should-skip? runner)
  (let ((run? (or (not (ref runner 'run-specifier))
		  ((ref runner 'run-specifier) runner)))
	(skip? ((apply test-match-any (ref runner 'skip-list)) runner)))
    (not (and run? (not skip?)))))

(define (test-expected-to-fail? runner)
  ((apply test-match-any (ref runner 'fail-list)) runner))

(define (boolean-equal? x y)
  (eq? (and x #t) (and y #t)))

(define (nearly=?? err)
  (lambda (x y)
    (<= (abs (- x y)) err)))

(define (err-equal? err-type condition)
  (or (and (eq? err-type #t) (condition? condition))
      (condition-has-type? condition err-type)))

(define-syntax test-comp
  (syntax-rules ()
    ((_ comp tname expected expr)
     (let ((runner (test-runner-get))
	   (name tname))
       (setup-runner runner name expr)
       ((test-runner-on-test-begin runner) runner)
       (unless (eq? (test-result-kind runner) 'skip)
	 (let ((exp expected)
	       (cmp comp))
	   (if (eq? cmp err-equal?)
	       (test-result-set! runner 'expected-error exp)
	       (test-result-set! runner 'expected-value exp))
	   (let1 res (with-error-handler
			 (lambda (e)
			   (test-result-set! runner 'actual-error e)
			   (and (eq? cmp err-equal?)
				(cmp exp e)))
		       (lambda ()
			 (let1 val expr
			   (test-result-set! runner 'actual-value val)
			   (and (not (eq? cmp err-equal?))
				(cmp exp val)))))
	     (test-result-set! runner 'result-kind (test-result runner res)))))
       (test-update-result runner)))))

(define-syntax setup-runner
  (syntax-rules ()
    ((_ runner name expr)
     (begin
       (test-result-clear runner)
       (set! (ref runner 'test-name) name)
       (and-let* ((p (current-load-port)))
	 (test-result-set! runner 'source-file (port-name p))
	 (test-result-set! runner 'source-line (port-current-line p)))
       (test-result-set! runner 'source-form 'expr)
       (test-result-set! runner 'result-kind
			 (cond ((test-should-skip? runner) 'skip)
			       ((test-expected-to-fail? runner) 'xfail)
			       (else #f)))))))

(define (test-result runner res)
  (if (eq? (test-result-kind runner) 'xfail)
      (if res 'xpass 'xfail)
      (if res 'pass 'fail)))

(define (test-update-result runner)
  (inc! (ref runner 'total-count))
  (case (test-result-kind runner)
    ((skip) (inc! (ref runner 'skip-count)))
    ((pass) (inc! (ref runner 'pass-count)))
    ((fail) (inc! (ref runner 'fail-count)))
    ((xpass) (inc! (ref runner 'xpass-count)))
    ((xfail) (inc! (ref runner 'xfail-count))))
  ((test-runner-on-test-end runner) runner))

(define (x->specifier spec)
  (cond ((procedure? spec) spec)
	((integer? spec) (test-match-nth 1 spec))
	((string? spec) (test-match-name spec))
	(else (error "invalid test specifier" spec))))

(define (test-runner-test-pos runner)
  (let* ((alist (test-result-alist runner))
	 (file (assq-ref alist 'source-file))
	 (line (assq-ref alist 'source-line)))
    (string-append (or file "")
		   (if file ":" "")
		   (if line (number->string line) "")
		   (if line ":" "")
		   (if (or file line) " " ""))))

(provide "srfi-64")