;;; Simple DSL for testing  -Phil Dawes 2007
;;;
;;; e.g. 
;;; (define-tests (mytests)
;;;   (target-function
;;;     ("can do something"
;;;       (assert-equal someresult (target-function something)))
;;;     ("and can do some other thing"
;;;       (some-setup-stuff)
;;;       (assert-equal someotherresult (target-function something-else)))
;;;   (my-other-function
;;;     ("also does some stuff"
;;;       (etc.. etc..))))
;;;
;;;
;;;  (mytests)     ; evaluates the tests and prints results
;;;
;;;


; hack alert! using an exception in order to fail when first assertion fails
; This should probably be a continuation, but syntax-rules makes it hard to
; pass the continuation to the assert macro
(define-syntax define-tests
  (syntax-rules ()
    ((define-test (name) (target-fn (casetext . casetest) ...) ...)
     (define (name) 
       (define tests 
	 `((target-fn 
            (casetext ,
             (lambda ()
               (with-exception-catcher   
                (lambda (e) (if (not (list? e))
                           (raise e)
                           e))
                (lambda () . casetest)))) ...) ...))
       (eval-test-suite name tests)))))

; run all the tests, then print the failure messages
(define (eval-test-suite name testbundles)
  (let ((results (map eval-function-tests testbundles)))
    (for-each (lambda (testbundle-results)
                (let ((targetfn (car testbundle-results)))
                  (for-each (lambda (res) 
                              (print-result targetfn res)) 
                            (cdr testbundle-results))))
              results)))


; returns (testbundle-name (list of results))
(define (eval-function-tests testbundle)
  (let ((targetfn (car testbundle))
        (tests (cdr testbundle)))  ; each test is (description thunk)
    (cons targetfn (map (lambda (t) (apply eval-test t)) tests))))

(define (print-result name res)
  (cond ((list? res)
         (print "\nFailed test:\n")
         (print name " - " (car res) "\n     ")             
         (write-failure-message (cdr res))
         (newline))
        ((pair? res)
         (print "\nFailed test:\n")
         (print name " - " (car res) "\n     ")
         (print "test returned " (cdr res))
         (newline)
         )))


(define (eval-test description thunk)
  (let ((res (thunk)))
    (if (equal? #t res)
        (begin (display ".")
               #t)
        (begin (display "F")
               (cons description res))
        )))


(define-syntax assert-equal
  (syntax-rules ()
    ((assert-equal one two)
     (let ((one-res one)
           (two-res two))
       (if (equal? one-res two-res)
           #t
           (raise (construct-failure-msg `(one two ,one-res ,two-res))))))))


(define (construct-failure-msg e)
  (list ">> (assert-equal " (car e) " " (cadr e) ") << \n     failed: " 
          (caddr e) " not equal to " (cadddr e)))


(define (write-failure-message msg-list)
  (for-each (lambda (s) (if (string? s) (print s) (write s))) 
            msg-list)
  (newline))

;;; TESTS below this line
  
(define (test-construct-failure-message)
  (write-failure-message (construct-failure-msg `(1 (+ 3 4) ,1 ,(+ 3 4)))))

(define-tests (example-tests)
  (my-first-function
   ("can eval truth"
    #t)
   ("can also eval false"
    (assert-equal 3 (list 55)))
   ("can handle two asserts in one line"
    (assert-equal 3 (list 55))   ; should assert false
    (assert-equal 3 3 ))
;;    ("can handle exceptions"
;;     (assert-equal 3 (+ 'foo 3)))  ; will raise an exception
   )
  (my-other-fn
   ("can do some really good stuff"
    #t)
   ("but sometimes breaks"
    #f)))