; 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/embedded-test
;
; Generation data:
;
;   Input revision: 16997
;   User: www-data
;   Machine: mononykus.freaks-unidos.net
;   Date: Mon Jul  5 21:23:17 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?)

(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~A: ~S..."
            (if (test-group-name test)
              (format #f " from group ~S" (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~A failed: ~S~%~{~A~%~}~%"
        (if (test-group-name test)
          (format #f " from group ~A" (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)))
      (unless (zero? 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")))))

(define-syntax test
  (syntax-rules ()
    ((test expr) (test expr #t))
    ((test expr expect) (test expr expect equal?))
    ((test expr expect cmp?) (test expr expect cmp? 'expr))
    ((test expr expect cmp? name) (test expr expect cmp? name *test-group-name*))
    ((test expr expect cmp? name group)
     (register-test group name (lambda () expr) (lambda () expect) cmp?))))

(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