; FILE AUTOMATICALLY GENERATED!
;
; This file was automatically generated by the svnwiki-scheme-library extension.
; The authoritative source for this is:
;
;   http://wiki.freaks-unidos.net/weblogs/azul/embedded-test
;
; Generation data:
;
;   Input revision: 17018
;   User: www-data
;   Machine: mononykus.freaks-unidos.net
;   Date: Sat Jul 10 09:08:53 2010

(module embedded-test (register-test run-tests test test-group test-error *test-group-name*)


(import scheme chicken)
(use srfi-1 format-compiler-base data-structures)

(define *tests* '())

(define-record test group-name name proc expect equal? location)

(define (register-test . args)
  (set! *tests* (cons (apply make-test args) *tests*)))

(define *test-group-name* #f)

(define test-error #f)

(define (errors-from-test test)
  (when (getenv "TESTS_VERBOSE")
    (format (current-error-port)
            "Test~@[ defined in ~A~]~@[ from group ~A~]: ~S..."
            (test-location test)
            (test-group-name test)
            (test-name test)))
  (let ((errors #f))
    (call-with-current-continuation
      (lambda (return)
        (set! test-error (lambda args (set! errors args) (return #f)))
        (let ((result ((test-proc test))) (expect ((test-expect test))))
          (unless ((test-equal? test) result expect)
            (set! errors
              (list (format #f "Expected: ~S~%Received: ~A" expect result)))))))
    (set! test-error #f)
    (when (getenv "TESTS_VERBOSE")
      (format (current-error-port) " ~A~%" (if errors "FAIL" "PASS")))
    (when errors
      (format (current-error-port)
              "Test~@[ defined in ~A~]~@[ from group ~A~] failed: ~S~%~{~A~%~}~%"
              (test-location test)
              (test-group-name test)
              (test-name test)
              errors))
    errors))

(define (run-tests)
  (when (getenv "TESTS_SHOW_GROUPS")
    (format (current-error-port) "Groups:~{ ~A~}~%"
            (delete-duplicates (map test-group-name (reverse *tests*)))))
  (when (getenv "TESTS")
    (let* ((tests (reverse
                    (filter
                      (let ((groups (map string->symbol
                                         (string-split
                                           (or (getenv "TESTS_GROUPS") "")
                                           " "))))
                        (if (null? groups)
                          identity
                          (compose (cut member <> groups)
                                   test-group-name)))
                      *tests*)))
           (failures (count errors-from-test tests)))
      (cond
        ((positive? failures)
         (format (current-error-port) "Tests failed.~%")
         (format (current-error-port) "Tests defined: ~A~%" (length *tests*))
         (format (current-error-port) "Tests executed: ~A (~A%)~%"
           (length tests)
           (* 100 (/ (length tests) (length *tests*))))
         (format (current-error-port) "Tests failed: ~A (executed: ~A%, defined: ~A%)~%"
           failures
           (* 100 (/ failures (length tests)))
           (* 100 (/ failures (length *tests*))))
         (error "Unit tests failed"))
        ((getenv "TESTS_VERBOSE")
         (format (current-error-port) "Tests passed.~%")
         (format (current-error-port) "Tests defined: ~A~%" (length *tests*))
         (format (current-error-port) "Tests executed: ~A (~A%)~%"
           (length tests)
           (* 100 (/ (length tests) (length *tests*)))))))))

(define-syntax (test x r c)
  `(,(r 'register-test)
    ,(if (> (length x) 5) (list-ref x 5) (r '*test-group-name*))
    ',(if (> (length x) 4) (list-ref x 4) (cadr x))
    (,(r 'lambda) () ,(cadr x))
    (,(r 'lambda) () ,(if (> (length x) 2) (list-ref x 2) #t))
    ,(if (> (length x) 3) (list-ref x 3) (r 'equal?))
    ,(get-line-number x)))

(define-syntax test-group
  (syntax-rules ()
    ((test-group name test ...)
     (begin
       (set! *test-group-name* 'name)
       test ...
       (set! *test-group-name* #f)))))

) ; close module def