;; DSL for testing


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


(define-syntax guarded-let
  (syntax-rules ()
    ((guarded-let initializers (destructor ...) stmt ...)
     (let initializers
         (dynamic-wind (lambda () '())
             (lambda () stmt ... )
             (lambda () destructor ...))))))



; run all the tests, then print the failure messages
(define (eval-test-suite name tests)
  (let ((results (map (lambda (test) (apply eval-test test)) tests)))
    (for-each (lambda (res) (print-result name res)) results)))

(define (print-result name res)
  ;(if (not (equal? #t res))
  (if (list? res)
      (begin (print "\nFailed test:\n")
             (print name " - " (car res) "\n     ")
             (write-failure-message (cdr res))
             (newline))))


(define (eval-test task thunk)
  (let ((res (thunk)))
    (if (equal? #t res)
        (begin (display ".")
               #t)
        (begin (display "F")
               (cons task 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-test (test-unittest)
  ("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