;;;; test-infrastructure-hygienic.scm - Test-macros and support code
;;;; Copyright (c) Peter K. Keller 2002
;;;; Written by Peter K. Keller (psilord@cs.wisc.edu) for use with the CHICKEN
;;;; scheme compiler and whoever else wants to use it. Just please include this
;;;; little paragraph in any source code derived from the original. This
;;;; source code is free to use for any purpose, but no warranty or guarantee 
;;;; to its stability or robustness is implied in any way. You may not hold me 
;;;; or anyone else liable for any use of this source code. Please try to keep 
;;;; this source code as close to R5RS(or later) scheme as possible. Thank you.

;; Make a destructor object which associates functions and arguments, and 
;; then applys the functions to the already evaluated arguments when
;; asked usually for the side effect of doing so, like removing a file.
;; It acts like a queue with the ordering of the functions it calls.
;; Any use of it returns a result that should be ignored.
;; WARNING, this is a message passing interface, however, the real API to
;; the destructor object is function-like. I split it up this way cause I 
;; this A) consitancy in the API is good, and B) it allows much changing
;; of the destructor object message passing interface that is hidden under the
;; function API. I want this because I think this object will change a lot in
;; the future, and the API separation will make for a good attempt at
;; preserving backwards compatibility. Please see the Destructor Object API...
(define test:make-destructor
  (lambda ()
    (let ((q '()))
      (lambda (message . args)
	(cond 
	 ((equal? message 'atexit)
	  (set! q (append q (list args)))
	  (test:make-ignore-result))

	 ((equal? message 'activate)
	  (for-each 
	   (lambda (promise)
	     ;; call all of the functions with args, usually for
	     ;; the side effects like removing files and what 
	     ;; not.
	     (apply (car promise) (cdr promise)))
	   q)
	  (set! q '())
	  (test:make-ignore-result))

	 ((equal? message 'clear)
	  (set! q '())
	  (test:make-ignore-result))

	 ((equal? message 'dump)
	  (let loop ((q q))
	    (if (null? q)
		#t
		(begin 
		  (write (car q))(newline)
		  (loop (cdr q)))))
	  (test:make-ignore-result))

	 (else
	 	(display "fix destructor message in else case")
		(newline)
		(test:make-ignore-result)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; perform a left to right evaluation of a list of expectations stopping at 
;; the first false one, and returning a list of all of the results from the 
;; evaluated expectations.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax test:eval-expectations
(syntax-rules ()
	((_ exp) 
		(list exp))

	((_ exp-head exp-tail ...)
		(let ((head exp-head)) ;; evaluate exp-head right here!
			(cond
			((or 
				;; XXX There might be a better way to do this check for 
				;; truth. I don't like this use of type checking functions
				;; here... It causes you to modify this when you add a new
				;; expectation type.
				(and	(expect-result? head) 
						(equal? #t 
							(expect-result-result-ref head)))
				(and	(expect-equivalence-result? head)
						(equal? #t 
							(expect-equivalence-result-result-ref head)))
				(and	(expect-tolerance-result? head)
						(equal? #t 
							(expect-tolerance-result-result-ref head)))

				;; assume ignored results are true for this macro so you
				;; can keep evaluating.
				(ignore-result? head)

				;; assume skipped results are true for this macro so you
				;; can keep evaluating.
				(skip-result? head)

				;; assume todo results are true for this macro so you
				;; can keep evaluating.
				(todo-result? head)

				;; assume gloss results are true for this macro so you
				;; can keep evaluating.
				(gloss-result? head))

				;; only continue evaluating down the list if the expectation
				;; turned out to be true
				(cons head (test:eval-expectations exp-tail ...)))

			(else ;; save the first false one in the master list
				(list head)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; perform a left to right evaluation of a list of exps returning a list of 
;; all of the results from the evaluated expectations.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax test:eval-lr
	(syntax-rules ()
		((_ exp) 
			(list exp))

		((_ exp-head exp-tail ...)
			(let ((head exp-head)) ;; evaluate exp-head right here!
				(cons head (test:eval-lr exp-tail ...))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; results that are to be ignored(like manipulation of the destructor object
;; inside a test case/package) must be stripped out of the evaluated 
;; test-results
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define test:strip-ignored-results
	(lambda (res)
		(cond
			((null? res)
				'())
			((ignore-result? (car res))
				(test:strip-ignored-results (cdr res)))
			(else
				(cons (car res) (test:strip-ignored-results (cdr res)))))))

;; this is the definition of the macro test-case:
;; (test-case DESC DEST-NAME TERM-NAME EXPECTATIONS)
;; (test-case DESC DEST-NAME TERM-NAME (warn WARNING) EXPECTATIONS)
;; (test-case DESC DEST-NAME TERM-NAME (FORMALS) EXPECTATIONS)
;; (test-case DESC DEST-NAME TERM-NAME (warn WARNING) (FORMALS) EXPECTATIONS)
;; DESC is an object (usually a string) that explains what the test-case is.
;; DEST-NAME is the name of the destructor object provided for you in the 
;; 	scope of the test-case(allows you to clean things up in case of 
;;	termination). The destructor object automatically when the expectations
;;	have finished for any reason.
;; TERM-NAME is the name of the escape function you must pass to (terminate ...)
;;	when you want to abort the test case.
;; EXPECTATIONS are a list of expect-* macros and destructor manipulation
;;	calls. The first expectation that fails stops the evaluation in the test
;;	case.
;; WARNING is a string(actually any type, but usually string) message that
;;	expains that something isn't quite right or there are special circumstances
;;	to something.
;; FORMALS are let-like bindings that become available to you inside the test
;;	case.

(define-syntax test-case
  (syntax-rules (warn)

  	;; NOTE: these rules are order dependent!

    ;; support the optional let bindings with warning syntax
    ((_ testname destname escape (warn warning) ((name value) ...) clauses ...)
    ((lambda (name ...)
	(let (	(warnobj warning) 
			(tname testname) 
			(destname (test:make-destructor)))
	  (let ((test-result 
		 (call-with-current-continuation
		  (lambda (escape)
		    (test:eval-expectations clauses ...)))))
		;; call the destructor to get rid of anything the user didn't want
		(destructor-activate! destname)
		(let ((stripped-test-result (test:strip-ignored-results test-result)))
			;; If the user exited via the terminate mechanism, then record this
			;; fact with a real terminate node in the tree.
	    	(cond ((terminate? stripped-test-result)
				(set! test-result 
					(list (test:make-terminate-result #f tname 'test-case stripped-test-result)))))
			;; return the typed list for this kind of test result
	    	(test:make-test-case-result (all-testcase-expectations-true? stripped-test-result) tname stripped-test-result warnobj))))) value ...))

    ;; support the optional let bindings
    ((_ testname destname escape ((name value) ...) clauses ...)
     ((lambda (name ...)
	(let ((tname testname) (destname (test:make-destructor)))
	  (let ((test-result 
		 (call-with-current-continuation
		  (lambda (escape)
		    (test:eval-expectations clauses ...)))))
		;; call the destructor to get rid of anything the user didn't want
		(destructor-activate! destname)
		(let ((stripped-test-result (test:strip-ignored-results test-result)))
			;; If the user exited via the terminate mechanism, then record this
			;; fact with a real terminate node in the tree.
	    	(cond ((terminate? stripped-test-result)
				(set! stripped-test-result 
					(list (test:make-terminate-result #f tname 'test-case stripped-test-result)))))
			;; return the typed list for this kind of test result
	    	(test:make-test-case-result 
				(all-testcase-expectations-true? stripped-test-result) tname stripped-test-result))))) value ...))


    ;; no let bindings with warning syntax
    ((_ testname destname escape (warn warning) clauses ...)
     (let ((warnobj warning)
	 		(tname testname) 
	 		(destname (test:make-destructor)))
       (let ((test-result
	      (call-with-current-continuation
	       (lambda (escape)
		 	(test:eval-expectations clauses ...)))))
		;; call the destructor to get rid of anything the user didn't want
		(destructor-activate! destname)
		(let ((stripped-test-result (test:strip-ignored-results test-result)))
			;; If the user exited via the terminate mechanism, then record this
			;; fact with a real terminate node in the tree.
	    	(cond ((terminate? stripped-test-result)
				(set! stripped-test-result 
					(list (test:make-terminate-result #f tname 'test-case stripped-test-result)))))
			;; return the typed list for this kind of test result
	 		(test:make-test-case-result 
				(all-testcase-expectations-true? stripped-test-result) tname stripped-test-result warnobj)))))

    ;; no let bindings 
    ((_ testname destname escape clauses ...)
     (let ((tname testname) 
	 		(destname (test:make-destructor)))
       (let ((test-result ;; invoke the expectations...
	      (call-with-current-continuation
	       (lambda (escape)
		 	(test:eval-expectations clauses ...)))))
		;; call the destructor to get rid of anything the user didn't want
		(destructor-activate! destname)
		(let ((stripped-test-result (test:strip-ignored-results test-result)))
			;; If the user exited via the terminate mechanism, then record this
			;; fact with a real terminate node in the tree.
	    	(cond ((terminate? stripped-test-result)
				(set! stripped-test-result 
					(list (test:make-terminate-result #f tname 'test-case stripped-test-result)))))
			;; return the typed list for this kind of test result
	 		(test:make-test-case-result 
				(all-testcase-expectations-true? stripped-test-result) tname stripped-test-result)))))))

;; this is the definition of the macro test-package:
;; (test-package DESC DEST-NAME TERM-NAME TESTCASES|TESTPACKAGES|EXPECTATIONS)
;; (test-package DESC DEST-NAME TERM-NAME (warn WARNING) TESTCASES|TESTPACKAGES|EXPECTATIONS)
;; (test-package DESC DEST-NAME TERM-NAME (FORMALS) TESTCASES|TESTPACKAGES|EXPECTATIONS)
;; (test-package DESC DEST-NAME TERM-NAME (warn WARNING) (FORMALS) TESTCASES|TESTPACKAGES|EXPECTATIONS)
;; DESC is an object (usually a string) that explains what the test-case is.
;; DEST-NAME is the name of the destructor object provided for you in the 
;; 	scope of the test-case(allows you to clean things up in case of 
;;	termination). The destructor object automatically when the expectations
;;	have finished for any reason.
;; TERM-NAME is the name of the escape function you must pass to (terminate ...)
;;	when you want to abort the test case.
;; TESTCASES|TESTPACKAGES|EXPECTATIONS is a list of test packages(they can nest)
;;	or test cases or expectations. An expectation used bare in a test package 
;;	DOES NOT have the auto short circut behaviour that it would in a test-case.
;;	Usually expectations are not placed bare into packages. However they
;;	can be, and the result tree walking code wil have to edal with it specially.
;; WARNING is a string(actually any type, but usually string) message that
;;	expains that something isn't quite right or there are special circumstances
;;	to something.
;; FORMALS are let-like bindings that become available to you inside the test
;;	package.
(define-syntax test-package
  (syntax-rules (warn)

  	;; NOTE: these rules are order dependent!

    ;; support the optional let bindings with warning syntax
    ((_ packagename destname escape (warn warning) ((name value) ...) clauses ...)
     ((lambda (name ...)
	(let ((warnobj warning)
			(pname packagename) (destname (test:make-destructor)))
	  (let ((test-result 
		 (call-with-current-continuation
		  (lambda (escape)
		    (test:eval-lr clauses ...)))))
		;; call the destructor to get rid of anything the user didn't want
		(destructor-activate! destname)
		(let ((stripped-test-result (test:strip-ignored-results test-result)))
			;; If the user exited via the terminate mechanism, then record this
			;; fact with a real terminate node in the tree.
	    	(cond ((terminate? stripped-test-result)
				(set! stripped-test-result 
					(list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
			;; return the typed list for this kind of test result
	    	(test:make-test-package-result (all-testpackage-results-true? stripped-test-result) pname stripped-test-result warnobj))))) value ...))

    ;; support the optional let bindings
    ((_ packagename destname escape ((name value) ...) clauses ...)
     ((lambda (name ...)
	(let ((pname packagename) (destname (test:make-destructor)))
	  (let ((test-result 
		 (call-with-current-continuation
		  (lambda (escape)
		    (test:eval-lr clauses ...)))))
		;; call the destructor to get rid of anything the user didn't want
		(destructor-activate! destname)
		(let ((stripped-test-result (test:strip-ignored-results test-result)))
			;; If the user exited via the terminate mechanism, then record this
			;; fact with a real terminate node in the tree.
	    	(cond ((terminate? stripped-test-result)
				(set! stripped-test-result 
					(list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
			;; 	return the typed list for this kind of test result
	    	(test:make-test-package-result (all-testpackage-results-true? stripped-test-result) pname stripped-test-result))))) value ...))

    ;; no let bindings with warning syntax
    ((_ packagename destname escape (warn warning) clauses ...)
     (let (	(warnobj warning)
	 		(pname packagename) (destname (test:make-destructor)))
       (let ((test-result
	      (call-with-current-continuation
	       (lambda (escape)
		 	(test:eval-lr clauses ...)))))
		;; call the destructor to get rid of anything the user didn't want
		(destructor-activate! destname)
		(let ((stripped-test-result (test:strip-ignored-results test-result)))
			;; If the user exited via the terminate mechanism, then record this
			;; fact with a real terminate node in the tree.
	    	(cond ((terminate? stripped-test-result)
				(set! stripped-test-result 
					(list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
			;; return the typed list for this kind of test result
	 		(test:make-test-package-result (all-testpackage-results-true? stripped-test-result) pname stripped-test-result warnobj)))))

    ;; no let bindings
    ((_ packagename destname escape clauses ...)
     (let ((pname packagename) (destname (test:make-destructor)))
       (let ((test-result
	      (call-with-current-continuation
	       (lambda (escape)
		 	(test:eval-lr clauses ...)))))
		;; call the destructor to get rid of anything the user didn't want
		(destructor-activate! destname)
		(let ((stripped-test-result (test:strip-ignored-results test-result)))
			;; If the user exited via the terminate mechanism, then record this
			;; fact with a real terminate node in the tree.
	    	(cond ((terminate? stripped-test-result)
				(set! stripped-test-result 
					(list (test:make-terminate-result #f pname 'test-package stripped-test-result)))))
			;; return the typed list for this kind of test result
	 	(test:make-test-package-result (all-testpackage-results-true? stripped-test-result) pname stripped-test-result)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This next small section of functions deal with creating unique identifiers
;; for various types of result objects. This allows us to do elegant html
;; generation(the ids are used as anchors) and I'm sure has other useful
;; features I have not yet discovered.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;
;; test:make-gen-label
;; This function accepts a prefix which it then uses to generate serial numbered
;; labels.
;;;;;;;;;;;;;;;;;;
(define test:make-gen-label
(lambda (p)
	(let ((prefix p) (id 0))
		(lambda ()
			(let ((oid id))
				(set! id (+ id 1))
				(string-append p "_"(number->string oid)))))))


;;;;;;;;;;;;;;;;;;
;; This function is a unique label generator so each result object can have
;; its own unique serial number for purposes of html generation, or data base
;; insertion.
;;;;;;;;;;;;;;;;;;

;; XXX This is a true top level define with state, need to figure out what
;; to do about this.... This means you just can't include this file in 
;; multiple places like a header file anymore.
(define test:gen-label (test:make-gen-label "result"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; These functions create/access typed result lists created by evaluating an
;; expect-*, testcase, or package.
;; In addition to each type of result, there are predicates
;; and accessor functions.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;
;; make a result type the is "ignored". This takes care of things like 
;; using the destructor object in a sequence of expectations.
;;;;;;;;;;;;;;;;;;
;; make a result type that is just plainly ignored.
(define test:make-ignore-result
	(lambda ()
		(list 'ignore-result #t)))

;; should I ignore something? (destructor or side-effect calls)
(define ignore-result?
	(lambda (l)
		(and (list? l) (equal? 'ignore-result (car l)))))

;;;;;;;;;;;;;;;;;;
;; evaluate the side effect expressions and return an ignored result no matter
;; what happens. Maybe some other day I might specialize this for some purpose.
;; (side-effect EXP)
(define-syntax side-effect
	(syntax-rules ()
	((_ clauses ...)
		(begin clauses ...
			(test:make-ignore-result)))))

;;;;;;;;;;;;;;;;;;
;; a simple function to make a warning list that has a #t in the car position
;; if a warning is present, and the warning in the cdr position, or a #f in the
;; car position, and an empty string in the cdr position, of no warning is
;; needed. A warning is always encapsulated into a result type, and is not
;; in and of itself a result type.
;;;;;;;;;;;;;;;;;;
(define test:make-warning
	(lambda args
		(if (and (not (null? args)) (not (zero? (length args))))
			`(warning #t ,@args)
			(list 'warning #f '()))))

;; normal predicate
(define test:warning? 
	(lambda (res)
		(cond
			((and (list? res) (equal? 'warning (list-ref res 0)))
				#t)
			(else
				#f))))

;; get the kind of the test case
(define test:warning-kind-ref
	(lambda (res)
		(if (test:warning? res)
			(list-ref res 0)
			'not-a-warning))) ;; XXX Hmm....

;; is the warning active?
(define test:warning-active?
	(lambda (res)
		(if (test:warning? res)
			(list-ref res 1)
			'not-a-warning))) ;; XXX Hmm....

;; return the warning user supplied object/message
(define test:warning-message-ref
	(lambda (res)
		(if (test:warning? res)
			(list-ref res 2)
			'not-a-warning))) ;; XXX Hmm....

;;;;;;;;;;;;;;;;;;
;; make-test-case-result
;; This function creates a result for an test-case that encapsulates
;; many expectation functions. Also included are the accessor
;; functions to various elements in the result.
;;;;;;;;;;;;;;;;;;
(define test:make-test-case-result
	(lambda (bool message expect-list . warning)
		(if (not (zero? (length warning)))
			(list 'test-case-result bool message expect-list 
				(apply test:make-warning warning) (test:gen-label))
			(list 'test-case-result bool message expect-list 
				(test:make-warning) (test:gen-label)))))


;; normal predicate
(define test-case-result?
	(lambda (res)
		(cond
			((and (list? res) (equal? 'test-case-result (list-ref res 0)))
				#t)
			(else
				#f))))

;; get the kind of the test case
(define test-case-result-kind-ref
	(lambda (res)
		(if (test-case-result? res)
			(list-ref res 0)
			'not-a-test-case-result))) ;; XXX Hmm....

;; get the result of the test case
(define test-case-result-result-ref
	(lambda (res)
		(if (test-case-result? res)
			(list-ref res 1)
			'not-a-test-case-result))) ;; XXX Hmm....

;; get the expectations of the test case
(define test-case-result-message-ref
	(lambda (res)
		(if (test-case-result? res)
			(list-ref res 2)
			'not-a-test-case-result))) ;; XXX Hmm....

;; get the expectations of the test case
(define test-case-result-expectations-ref
	(lambda (res)
		(if (test-case-result? res)
			(list-ref res 3)
			'not-a-test-case-result))) ;; XXX Hmm....

;; if a warning has been set on this node, return #t
(define test-case-result-warning?
	(lambda (res)
		(if (test-case-result? res)
			(test:warning-active? (list-ref res 4))
			'not-a-test-case-result))) ;; XXX Hmm....

;; get the warning object, or the default if none.
(define test-case-result-warning-ref
	(lambda (res)
		(if (test-case-result? res)
			(test:warning-message-ref (list-ref res 4))
			'not-a-test-case-result))) ;; XXX Hmm....

;; get unique serial number associated with this result object.
(define test-case-result-id-ref
	(lambda (res)
		(if (test-case-result? res)
			(list-ref res 5)
			'not-a-test-case-result))) ;; XXX Hmm....

;;;;;;;;;;;;;;;;;;
;; make-test-package-result
;; This function creates a result for an test-package that encapsulates
;; many test-case functions. Also included are the accessor
;; functions to various elements in the result.
;;;;;;;;;;;;;;;;;;
(define test:make-test-package-result
	(lambda (bool message *-result-list . warning)
		(if (not (zero? (length warning)))
			(list 'test-package-result bool message *-result-list 
				(apply test:make-warning warning) (test:gen-label))
			(list 'test-package-result bool message *-result-list 
				(test:make-warning) (test:gen-label)))))

;; normal predicate
(define test-package-result?
	(lambda (res)
		(cond
			((and (list? res) (equal? 'test-package-result (list-ref res 0)))
				#t)
			(else
				#f))))

;; get the kind of the test package
(define test-package-result-kind-ref
	(lambda (res)
		(if (test-package-result? res)
			(list-ref res 0)
			'not-a-test-package-result))) ;; XXX Hmm....

;; get the result of the test package
(define test-package-result-result-ref
	(lambda (res)
		(if (test-package-result? res)
			(list-ref res 1)
			'not-a-test-package-result))) ;; XXX Hmm....


;; get the message of the test package
(define test-package-result-message-ref
	(lambda (res)
		(if (test-package-result? res)
			(list-ref res 2)
			'not-a-test-package-result))) ;; XXX Hmm....

;; get the expectations of the test package
(define test-package-result-exps-ref
	(lambda (res)
		(if (test-package-result? res)
			(list-ref res 3)
			'not-a-package-case-result))) ;; XXX Hmm....

;; if a warning has been set on this node, return #t
(define test-package-result-warning?
	(lambda (res)
		(if (test-package-result? res)
			(test:warning-active? (list-ref res 4))
			'not-a-test-package-result))) ;; XXX Hmm....

;; get the warning object, or the default if none.
(define test-package-result-warning-ref
	(lambda (res)
		(if (test-package-result? res)
			(test:warning-message-ref (list-ref res 4))
			'not-a-test-package-result))) ;; XXX Hmm....

;; get serial number of the test package
(define test-package-result-id-ref
	(lambda (res)
		(if (test-package-result? res)
			(list-ref res 5)
			'not-a-package-case-result))) ;; XXX Hmm....

;;;;;;;;;;;;;;;;;;
;; make-expect-result
;; This function creates a result list for an expectation that just 
;; manipulates a single expression only. Also included are the accessor
;; functions to various elements in the result.
;;;;;;;;;;;;;;;;;;
(define test:make-expect-result
	(lambda (result specifics message unevaled evaled . warning)
		(if (not (zero? (length warning)))
			(list 'expect-result result specifics message unevaled evaled
				(apply test:make-warning warning) (test:gen-label))
			(list 'expect-result result specifics message unevaled evaled
				(test:make-warning) (test:gen-label)))))

;; normal predicate
(define expect-result?
	(lambda (res)
		(cond
			((and (list? res) (equal? 'expect-result (list-ref res 0)))
				#t)
			(else
				#f))))

;; get the kind of exepctation
(define expect-result-kind-ref
	(lambda (res)
		(if (expect-result? res)
			(list-ref res 0)
			'not-an-expect-result))) ;; XXX Hmm....

;; get the result of the expectation 
(define expect-result-result-ref
	(lambda (res)
		(if (expect-result? res)
			(list-ref res 1)
			'not-an-expect-result))) ;; XXX Hmm....

;; get the specifics of expectation 
(define expect-result-specific-ref
	(lambda (res)
		(if (expect-result? res)
			(list-ref res 2)
			'not-an-expect-result))) ;; XXX Hmm....

;; get the user supplied message 
(define expect-result-message-ref
	(lambda (res)
		(if (expect-result? res)
			(list-ref res 3)
			'not-an-expect-result))) ;; XXX Hmm....

;; get the user supplied unevaluated expression
(define expect-result-unevaled-ref
	(lambda (res)
		(if (expect-result? res)
			(list-ref res 4)
			'not-an-expect-result))) ;; XXX Hmm....

;; get the user supplied evaluated expression
(define expect-result-evaled-ref
	(lambda (res)
		(if (expect-result? res)
			(list-ref res 5)
			'not-an-expect-result))) ;; XXX Hmm....

;; if a warning has been set on this node, return #t
(define expect-result-warning?
	(lambda (res)
		(if (expect-result? res)
			(test:warning-active? (list-ref res 6))
			'not-an-expect-result))) ;; XXX Hmm....

;; get the warning object, or the default if none.
(define expect-result-warning-ref
	(lambda (res)
		(if (expect-result? res)
			(test:warning-message-ref (list-ref res 6))
			'not-an-expect-result))) ;; XXX Hmm....

;; get the unique serial number
(define expect-result-id-ref
	(lambda (res)
		(if (expect-result? res)
			(list-ref res 7)
			'not-an-expect-result))) ;; XXX Hmm....

;;;;;;;;;;;;;;;;;;
;; make-expect-equivalence-result
;; This function creates a result for an exception that is comparing two things
;; together somehow. It holds an evaled lhs and a unevaled and evaled
;; rhs of an equivalence operation.
;;;;;;;;;;;;;;;;;;
(define test:make-expect-equivalence-result
	(lambda (result specific message lhs rhs-unevaled rhs-evaled . warning)
		(if (not (zero? (length warning)))
			(list 'expect-equivalence-result result specific message 
				lhs rhs-unevaled rhs-evaled (apply test:make-warning warning)
				(test:gen-label))
			(list 'expect-equivalence-result result specific message 
				lhs rhs-unevaled rhs-evaled (test:make-warning)
				(test:gen-label)))))

;; normal predicate
(define expect-equivalence-result?
	(lambda (res)
		(cond
			((and	(list? res) 
					(equal? 'expect-equivalence-result (list-ref res 0)))
				#t)
			(else
				#f))))

;; get the kind of the expectation 
(define expect-equivalence-result-kind-ref
	(lambda (res)
		(if (expect-equivalence-result? res)
			(list-ref res 0)
			'not-an-expect-equivalence-result))) ;; XXX Hmm....

;; get the result of the expectation 
(define expect-equivalence-result-result-ref
	(lambda (res)
		(if (expect-equivalence-result? res)
			(list-ref res 1)
			'not-an-expect-equivalence-result))) ;; XXX Hmm....

;; get the specifics of the expectation 
(define expect-equivalence-result-specific-ref
	(lambda (res)
		(if (expect-equivalence-result? res)
			(list-ref res 2)
			'not-an-expect-equivalence-result))) ;; XXX Hmm....

;; get the user supplied message 
(define expect-equivalence-result-message-ref
	(lambda (res)
		(if (expect-equivalence-result? res)
			(list-ref res 3)
			'not-an-expect-equivalence-result))) ;; XXX Hmm....

;; get the user supplied evaluated lhs
(define expect-equivalence-result-lhs-evaled-ref
	(lambda (res)
		(if (expect-equivalence-result? res)
			(list-ref res 4)
			'not-an-expect-equivalence-result))) ;; XXX Hmm....

;; get the user supplied unevaluated rhs
(define expect-equivalence-result-rhs-unevaled-ref
	(lambda (res)
		(if (expect-equivalence-result? res)
			(list-ref res 5)
			'not-an-expect-equivalence-result))) ;; XXX Hmm....

;; get the user supplied evaluated rhs
(define expect-equivalence-result-rhs-evaled-ref
	(lambda (res)
		(if (expect-equivalence-result? res)
			(list-ref res 6)
			'not-an-expect-equivalence-result))) ;; XXX Hmm....
			
;; if a warning has been set on this node, return #t
(define expect-equivalence-result-warning?
	(lambda (res)
		(if (expect-equivalence-result? res)
			(test:warning-active? (list-ref res 7))
			'not-an-expect-equivalence-result))) ;; XXX Hmm....

;; get the warning object, or the default if none.
(define expect-equivalence-result-warning-ref
	(lambda (res)
		(if (expect-equivalence-result? res)
			(test:warning-message-ref (list-ref res 7))
			'not-an-expect-equivalence-result))) ;; XXX Hmm....

;; get the unique serial number for this result
(define expect-equivalence-result-id-ref
	(lambda (res)
		(if (expect-equivalence-result? res)
			(list-ref res 8)
			'not-an-expect-equivalence-result))) ;; XXX Hmm....

;;;;;;;;;;;;;;;;;;
;; make-expect-tolerance-result
;; This function creates a result for an expectation that is comparing two 
;; numbers together within a tolerance. It holds a message, evaled lhs, 
;; evaled tolerance, and an unevaled and evaled rhs.
;;;;;;;;;;;;;;;;;;

;; holds an evaled lhs and tolerance and an unevaled and evaled rhs
(define test:make-expect-tolerance-result
	(lambda (result style message lhs tol rhs-unevaled rhs-evaled . warning)
		(if (not (zero? (length warning)))
			(list 'expect-tolerance-result result style message 
				lhs tol rhs-unevaled rhs-evaled 
				(apply test:make-warning warning)
				(test:gen-label))
			(list 'expect-tolerance-result result style message 
				lhs tol rhs-unevaled rhs-evaled (test:make-warning)
				(test:gen-label)))))

;; normal predicate
(define expect-tolerance-result?
	(lambda (res)
		(cond
			((and	(list? res) 
					(equal? 'expect-tolerance-result (list-ref res 0)))
				#t)
			(else
				#f))))

;; get the kind of expectation 
(define expect-tolerance-result-kind-ref
	(lambda (res)
		(if (expect-tolerance-result? res)
			(list-ref res 0)
			'not-an-expect-tolerance-result))) ;; XXX Hmm....

;; get the result of the expectation 
(define expect-tolerance-result-result-ref
	(lambda (res)
		(if (expect-tolerance-result? res)
			(list-ref res 1)
			'not-an-expect-tolerance-result))) ;; XXX Hmm....

;; get the specific type of tolerance
(define expect-tolerance-result-specific-ref
	(lambda (res)
		(if (expect-tolerance-result? res)
			(list-ref res 2)
			'not-an-expect-tolerance-result))) ;; XXX Hmm....

;; get the user supplied message 
(define expect-tolerance-result-message-ref
	(lambda (res)
		(if (expect-tolerance-result? res)
			(list-ref res 3)
			'not-an-expect-tolerance-result))) ;; XXX Hmm....

;; get the user supplied evaluated lhs
(define expect-tolerance-result-lhs-evaled-ref
	(lambda (res)
		(if (expect-tolerance-result? res)
			(list-ref res 4)
			'not-an-expect-tolerance-result))) ;; XXX Hmm....

;; get the user supplied evaluate lhs tolerance
(define expect-tolerance-result-lhs-tol-evaled-ref
	(lambda (res)
		(if (expect-tolerance-result? res)
			(list-ref res 5)
			'not-an-expect-tolerance-result))) ;; XXX Hmm....

;; get the user supplied unevaluated rhs
(define expect-tolerance-result-rhs-unevaled-ref
	(lambda (res)
		(if (expect-tolerance-result? res)
			(list-ref res 6)
			'not-an-expect-tolerance-result))) ;; XXX Hmm....

;; get the user supplied evaluated rhs
(define expect-tolerance-result-rhs-evaled-ref
	(lambda (res)
		(if (expect-tolerance-result? res)
			(list-ref res 7)
			'not-an-expect-tolerance-result))) ;; XXX Hmm....

;; if a warning has been set on this node, return #t
(define expect-tolerance-result-warning?
	(lambda (res)
		(if (expect-tolerance-result? res)
			(test:warning-active? (list-ref res 8))
			'not-an-expect-tolerance-result))) ;; XXX Hmm....

;; get the warning object, or the default if none.
(define expect-tolerance-result-warning-ref
	(lambda (res)
		(if (expect-tolerance-result? res)
			(test:warning-message-ref (list-ref res 8))
			'not-an-expect-tolerance-result))) ;; XXX Hmm....

;; get the unique serial number for this result
(define expect-tolerance-result-id-ref
	(lambda (res)
		(if (expect-tolerance-result? res)
			(list-ref res 9)
			'not-an-expect-tolerance-result))) ;; XXX Hmm....

;;;;;;;;;;;;;;;;;;
;; make-terminate-result
;; This function creates a result for when an escape procedure gets 
;; called in a test case or package.
;;;;;;;;;;;;;;;;;;
(define test:make-terminate-result
	(lambda (result scope container message)
		(list 'terminate-result result scope container (terminate-message-ref 
			message) (test:gen-label))))

;; these next THREE functions are what a user calls in a test case to exit
;; a test forcibly. Once this happens, this little list that is made is
;; converted into a true termination-result type in the test-case or 
;; test-package. I'm sorry it had to be split this way...
;;;;;;;;;;;;;;;;;;;;
;; this is the user called call/cc activation wrapper, call this when you 
;; want to terminate the computation at the efunc continuation level in 
;; some test. It allows passing of a message-like object to describe what
;; happened and why the terminator was called.
;;;;;;;;;;;;;;;;;;;;
(define terminate
	(lambda (efunc message)
		(efunc (list 'user-termination message))))

;; simple check for the user termination used internally
(define terminate?
	(lambda (res)
		(cond
			((and	(list? res) 
					(equal? 'user-termination (list-ref res 0)))
				#t)
			(else
				#f))))

;; grab the message out of the user supplied termiante event
(define terminate-message-ref
	(lambda (res)
		(if (terminate? res)
			(list-ref res 1)
			'not-a-user-termination))) ;; XXX Hmm....

;; back to the terminate result code....

;; normal predicate
(define terminate-result?
	(lambda (res)
		(cond
			((and	(list? res) 
					(equal? 'terminate-result (list-ref res 0)))
				#t)
			(else
				#f))))

;; retrive the (internal type) kind of the termination result
(define terminate-result-kind-ref
	(lambda (res)
		(if (terminate-result? res)
			(list-ref res 0)
			'not-a-terminate-result))) ;; XXX Hmm....

;; retrieve the "result" of the termination XXX hard set to #f currently...
(define terminate-result-result-ref
	(lambda (res)
		(if (terminate-result? res)
			(list-ref res 1)
			'not-a-terminate-result))) ;; XXX Hmm....

;; retrive the scope of the termination type, this is the associated 
;; descriptive message the user supplies with the test-case or test-package
(define terminate-result-scope-ref
	(lambda (res)
		(if (terminate-result? res)
			(list-ref res 2)
			'not-a-terminate-result))) ;; XXX Hmm....

;; retrive the container of the termination type, this will be things like 
;; 'test-case or 'test-package, basically the container the terminate
;; occured in.
(define terminate-result-container-ref
	(lambda (res)
		(if (terminate-result? res)
			(list-ref res 3)
			'not-a-terminate-result))) ;; XXX Hmm....

;; retrive the user supplied message from the terminate event
(define terminate-result-message-ref
	(lambda (res)
		(if (terminate-result? res)
			(list-ref res 4)
			'not-a-terminate-result))) ;; XXX Hmm....

;; retrive the unique serial number of the termination
(define terminate-result-id-ref
	(lambda (res)
		(if (terminate-result? res)
			(list-ref res 5)
			'not-a-terminate-result))) ;; XXX Hmm....

;;;;;;;;;;;;;;;;;;
;; todo-result
;; This result type makes it know that something still has to be implemented
;; or done. It is seperate from the gloss result so you can count up the 
;; number of todos you have, or do other things based on noticing them.
;;;;;;;;;;;;;;;;;;
(define test:make-todo-result
	(lambda (message . warning)
		(if (not (zero? (length warning)))
			(list 'todo-result message (apply test:make-warning warning)
				(test:gen-label))
			(list 'todo-result message (test:make-warning)
				(test:gen-label)))))

;; normal predicate
(define todo-result?
	(lambda (res)
		(cond
			((and	(list? res) 
					(equal? 'todo-result (list-ref res 0)))
				#t)
			(else
				#f))))

;; retrive the user supplied message from the todo event
(define todo-result-message-ref
	(lambda (res)
		(if (todo-result? res)
			(list-ref res 1)
			'not-a-todo-result))) ;; XXX Hmm....

;; if a warning has been set on this node, return #t
(define todo-result-warning?
	(lambda (res)
		(if (todo-result? res)
			(test:warning-active? (list-ref res 2))
			'not-a-todo-result))) ;; XXX Hmm....

;; get the warning object or the default if none.
(define todo-result-warning-ref
	(lambda (res)
		(if (todo-result? res)
			(test:warning-message-ref (list-ref res 2))
			'not-a-todo-result))) ;; XXX Hmm....

;; retrive the unique serial number for this result
(define todo-result-id-ref
	(lambda (res)
		(if (todo-result? res)
			(list-ref res 3)
			'not-a-todo-result))) ;; XXX Hmm....

;; the macro the user uses to create the todo
;; (todo MESSAGE)
;; (todo MESSAGE (warn WARNING))
(define-syntax todo
	(syntax-rules (warn)

	;; with warning syntax
	((_ message (warn warning))
		(let ((warnobj warning) (msg message))
			(test:make-todo-result msg warnobj)))

	;; without warning syntax
	((_ message)
		(let ((msg message))
			(test:make-todo-result msg)))))

;;;;;;;;;;;;;;;;;;
;; gloss-result
;; This is a result type of pure description that the user can insert into
;; a test package or a test case. Usually used for messages about the tests
;; being done. This result type usually has no value other than to be printed
;; out in the output so someone can read it.
;;;;;;;;;;;;;;;;;;
(define test:make-gloss-result
	(lambda (message . warning)
		(if (not (zero? (length warning)))
			(list 'gloss-result message (apply test:make-warning warning)
				(test:gen-label))
			(list 'gloss-result message (test:make-warning)
				(test:gen-label)))))

;; normal predicate
(define gloss-result?
	(lambda (res)
		(cond
			((and	(list? res) 
					(equal? 'gloss-result (list-ref res 0)))
				#t)
			(else
				#f))))

;; retrive the user supplied message from the gloss event
(define gloss-result-message-ref
	(lambda (res)
		(if (gloss-result? res)
			(list-ref res 1)
			'not-a-gloss-result))) ;; XXX Hmm....

;; if a warning has been set on this node, return #t
(define gloss-result-warning?
	(lambda (res)
		(if (gloss-result? res)
			(test:warning-active? (list-ref res 2))
			'not-a-gloss-result))) ;; XXX Hmm....

;; get the warning object or the default if none.
(define gloss-result-warning-ref
	(lambda (res)
		(if (gloss-result? res)
			(test:warning-message-ref (list-ref res 2))
			'not-a-gloss-result))) ;; XXX Hmm....

;; retrive the unique serial number for this result
(define gloss-result-id-ref
	(lambda (res)
		(if (gloss-result? res)
			(list-ref res 3)
			'not-a-gloss-result))) ;; XXX Hmm....

;; the macro the user uses to create the gloss
;; (gloss MESSAGE)
;; (gloss MESSAGE (warn WARNING))
(define-syntax gloss
	(syntax-rules (warn)

	;; with warning syntax
	((_ message (warn warning))
		(let ((warnobj warning) (msg message))
			(test:make-gloss-result msg warnobj)))

	;; without warning syntax
	((_ message)
		(let ((msg message))
			(test:make-gloss-result msg)))))

;;;;;;;;;;;;;;;;;;
;; skip-result
;; This result type makes it known that something has been skipped
;; It is seperate from the gloss result so you can count up the 
;; number of skips you have, or do other things based on noticing them.
;;;;;;;;;;;;;;;;;;
(define test:make-skip-result
	(lambda (message . warning)
		(if (not (zero? (length warning)))
			(list 'skip-result message (apply test:make-warning warning)
				(test:gen-label))
			(list 'skip-result message (test:make-warning)
				(test:gen-label)))))

;; normal predicate
(define skip-result?
	(lambda (res)
		(cond
			((and	(list? res) 
					(equal? 'skip-result (list-ref res 0)))
				#t)
			(else
				#f))))

;; retrive the user supplied message from the skip event
(define skip-result-message-ref
	(lambda (res)
		(if (skip-result? res)
			(list-ref res 1)
			'not-a-skip-result))) ;; XXX Hmm....

;; if a warning has been set on this node, return #t
(define skip-result-warning?
	(lambda (res)
		(if (skip-result? res)
			(test:warning-active? (list-ref res 2))
			'not-a-skip-result))) ;; XXX Hmm....

;; get the warning object or the default if none.
(define skip-result-warning-ref
	(lambda (res)
		(if (skip-result? res)
			(test:warning-message-ref (list-ref res 2))
			'not-a-skip-result))) ;; XXX Hmm....

;; retrive the unique serial number for this result
(define skip-result-id-ref
	(lambda (res)
		(if (skip-result? res)
			(list-ref res 3)
			'not-a-skip-result))) ;; XXX Hmm....

;; the macro the user uses to create a skipped entity. The clauses that
;; come in the skip are just totally removed and not even computed by the
;; macro.
;; (skip MESSAGE clauses ...)
;; (skip MESSAGE (warn WARNING) clauses ...)
(define-syntax skip
	(syntax-rules (warn)

	;; with warning syntax
	((_ message (warn warning) clauses ...) ;; ignore the clauses
		(let ((warnobj warning) (msg message))
			(test:make-skip-result msg warnobj)))

	;; without warning syntax
	((_ message clauses ...) ;; ignore the clauses
		(let ((msg message))
			(test:make-skip-result msg)))))

;;;;;;;;;;;;;;;;;;
;; Destructor Object API
;; This is a function API for the message-passing style destructor object.
;; The impetus to this is I think in the future this lower-level API will
;; change a lot, and by separating the API to it to a high and low level
;; API, should allow me greater flexibility in maintaining backwards
;; compatibility. All destructor calls produce an ignore result the the
;; user actually never sees. XXX WARNING XXX It is very hard, if not
;; impossible, to typecheck the arguments and be sure that a destructor
;; object was actually passed as the first argument. So in the docs for this
;; API, it should be said to be VERY CAREFUL with the arguments and make sure
;; they are correct.
;;;;;;;;;;;;;;;;;;

(define destructor-atexit!
	(lambda (dobj . args)
		(apply dobj `(,'atexit ,@args))))

(define destructor-activate!
	(lambda (dobj . args)
		(apply dobj `(,'activate ,@args))))

(define destructor-clear!
	(lambda (dobj . args)
		(apply dobj `(,'clear ,@args))))

(define destructor-dump
	(lambda (dobj . args)
		(apply dobj `(,'dump ,@args))))

;;;;;;;;;;;;;;;;;;
;; check to see if something is a typed node of any kind generated by a 
;; expectation, test-case, or test-package
;;;;;;;;;;;;;;;;;;
(define *-result?
	(lambda (thingy)
		(or (skip-result? thingy)
			(todo-result? thingy)
			(gloss-result? thingy)
			(terminate-result? thingy)
			(expect-result? thingy)
			(expect-equivalence-result? thingy)
			(expect-tolerance-result? thingy)
			(test-case-result? thingy)
			(test-package-result? thingy))))

;;;;;;;;;;;;;;;;;;
;; grab out the result value of any correctly typed quantity without caring
;; what it is.
;;;;;;;;;;;;;;;;;;
(define *-result-ref
	(lambda (thingy)
		(cond
			((skip-result? thingy) ;; just ignore this and assume truth
				#t)
			((gloss-result? thingy) ;; just ignore this and assume truth
				#t)
			((todo-result? thingy) ;; just ignore this and assume truth
				#t)
			((terminate-result? thingy)
				(terminate-result-result-ref thingy))
			((expect-result? thingy)
				(expect-result-result-ref thingy))
			((expect-equivalence-result? thingy)
				(expect-equivalence-result-result-ref thingy))
			((expect-tolerance-result? thingy)
				(expect-tolerance-result-result-ref thingy))
			((test-case-result? thingy)
				(test-case-result-result-ref thingy))
			((test-package-result? thingy)
				(test-package-result-result-ref thingy))
			((terminate-result? thingy)
				(terminate-result-result-ref thingy))
			(else
				(display "Error! *-result-ref not passed a result type")
				(newline)
				#f))))

;;;;;;;;;;;;;;;;;;
;; return true if a warning in the result object exists, for result objects
;; that do not contain a warning, return #f
;;;;;;;;;;;;;;;;;;
(define *-warning?
	(lambda (thingy)
		(cond
			((skip-result? thingy)
				(skip-result-warning? thingy))
			((gloss-result? thingy)
				(gloss-result-warning? thingy))
			((todo-result? thingy)
				(todo-result-warning? thingy))
			((terminate-result? thingy) ;; termination objs do not have warnings
				#f)
			((expect-result? thingy)
				(expect-result-warning? thingy))
			((expect-equivalence-result? thingy)
				(expect-equivalence-result-warning? thingy))
			((expect-tolerance-result? thingy)
				(expect-tolerance-result-warning? thingy))
			((test-case-result? thingy)
				(test-case-result-warning? thingy))
			((test-package-result? thingy)
				(test-package-result-warning? thingy))
			(else
				(display "Error! *-warning? not passed a result type")
				(newline)
				#f))))

;;;;;;;;;;;;;;;;;;
;; see if a list of generic results in a package are all true, this does not
;; recurse down any constructed tree of results, it just looks at the roots
;;;;;;;;;;;;;;;;;;
(define all-testpackage-results-true?
(lambda (rlist)
(letrec ((recurse
			(lambda (count rlist)
				(cond
					((and (null? rlist) (not (zero? count)))
						#t)
					((and (null? rlist) (zero? count))
						#f)
					((equal? #t (*-result-ref (car rlist)))
						(recurse (+ count 1) (cdr rlist)))
					(else
						#f)))))
	(recurse 0 rlist))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Here are some functions to walk result trees or lists and determine useful
;; things about them
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; See if a list of various expectation results are all true or not
(define all-testcase-expectations-true?
(lambda (el)
(letrec ((check-expectations
	(lambda (count el)
		(cond 
			;; if the list is passed in empty, then no, they didn't pass
			((and (null? el) (zero? count))
				#f)

			;; if I counted more than one thing, and then hit the empty
			;; list, then all of them were true
			((and (null? el) (not (zero? count)))
				#t)
			
			;; check the various kinds of expectation results.
			((and	(expect-result? (car el))
					(equal? #t (expect-result-result-ref (car el))))
				(check-expectations (+ count 1) (cdr el)))

			((and	(expect-equivalence-result? (car el))
					(equal? #t (expect-equivalence-result-result-ref (car el))))
				(check-expectations (+ count 1) (cdr el)))

			((and	(expect-tolerance-result? (car el))
					(equal? #t (expect-tolerance-result-result-ref (car el))))
				(check-expectations (+ count 1) (cdr el)))

			((skip-result? (car el))
				;; just consider this true since it is supposed to be
				;; transparent to this function and holds no value other
				;; than the message it carries.
				(check-expectations (+ count 1) (cdr el)))

			((gloss-result? (car el))
				;; just consider this true since it is supposed to be
				;; transparent to this function and holds no value other
				;; than the message it carries.
				(check-expectations (+ count 1) (cdr el)))

			((todo-result? (car el))
				;; just consider this true since it is supposed to be
				;; transparent to this function and holds no value other
				;; than the message it carries.
				(check-expectations (+ count 1) (cdr el)))

			;; XXX Hmm.... I don't think this should be here...
			;; XXX Hmm... figure why I wrote the above comment. I forgot.
			((and	(terminate-result? (car el))
					(equal? #t (terminate-result-result-ref (car el))))
				(check-expectations (+ count 1) (cdr el)))

			;; if something wasn't true, then stop
			(else
				#f)))))
(check-expectations 0 el))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Here is the big section that contains all of the various expect-* functions
;; for anything you might need.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-zero: Expect a value that will be exactly zero
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define test:_expect-zero
  (lambda (msg val)
    (zero? val)))

(define-syntax expect-zero
  (syntax-rules (warn)

	;; with optional warning syntax
	((_ msg (warn warning) val)
     (let ((warnobj warning) (message msg) (value val))
       (let ((result (test:_expect-zero message value)))
		 (test:make-expect-result result "zero" message 'val value warnobj))))

	;; without optional warning syntax
    ((_ msg val)
     (let ((message msg) (value val))
       (let ((result (test:_expect-zero message value)))
		 (test:make-expect-result result "zero" message 'val value))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-nonzero: Expect a value to be non-zero
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define test:_expect-nonzero
  (lambda (msg val)
    (not (zero? val))))

(define-syntax expect-nonzero
  (syntax-rules (warn)

	;; with optional warning syntax
    ((_ msg (warn warning) val)
     (let ((warnobj warning) (message msg) (value val))
       (let ((result (test:_expect-nonzero message value)))
	 	(test:make-expect-result result "nonzero" message 'val value warnobj))))

	;; without optional warning syntax
    ((_ msg val)
     (let ((message msg) (value val))
       (let ((result (test:_expect-nonzero message value)))
	 	(test:make-expect-result result "nonzero" message 'val value))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-true: Expect a value to be #t
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define test:_expect-true
  (lambda (msg val)
    (equal? #t val)))

(define-syntax expect-true
  (syntax-rules (warn)

	;; with optional warning syntax
    ((_ msg (warn warning) val)
     (let ((warnobj warning) (message msg) (value val))
       (let ((result (test:_expect-true message value)))
	 	(test:make-expect-result result "true" message 'val value warnobj))))

	;; without optional warning syntax
    ((_ msg val)
     (let ((message msg) (value val))
       (let ((result (test:_expect-true message value)))
	 	(test:make-expect-result result "true" message 'val value))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-false: Expect a value to be #f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define test:_expect-false
  (lambda (msg val)
    (equal? #f val)))

(define-syntax expect-false
  (syntax-rules (warn)

	;; with optional warning syntax
    ((_ msg (warn warning) val)
     (let ((warnobj warning) (message msg) (value val))
       (let ((result (test:_expect-false message value)))
	 	(test:make-expect-result result "false" message 'val value warnobj))))

	;; without optional warning syntax
    ((_ msg val)
     (let ((message msg) (value val))
       (let ((result (test:_expect-false message value)))
	 	(test:make-expect-result result "false" message 'val value))))))
					

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-eq: Expect the eq? relation to hold between val and arg
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define test:_expect-eq
  (lambda (msg val arg)
    (eq? val arg)))

(define-syntax expect-eq
  (syntax-rules (warn)

	;; with optional warning syntax
    ((expect-eq msg (warn warning) val arg)
     (let ((warnobj warning) (message msg) (value val) (argument arg))
       (let ((result (test:_expect-eq message value argument)))
	 	(test:make-expect-equivalence-result result "eq" message 
			value 'arg argument warnobj))))

	;; without optional warning syntax
    ((expect-eq msg val arg)
     (let ((message msg) (value val) (argument arg))
       (let ((result (test:_expect-eq message value argument)))
	 	(test:make-expect-equivalence-result result "eq" message 
			value 'arg argument))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-eqv: Expect the eqv? relation to hold between val and arg
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define test:_expect-eqv
  (lambda (msg val arg)
    (eqv? val arg)))

(define-syntax expect-eqv
  (syntax-rules (warn)

	;; with optional warning syntax
    ((_ msg (warn warning) val arg)
     (let ((warnobj warning) (message msg) (value val) (argument arg))
       (let ((result (test:_expect-eqv message value argument)))
	 	(test:make-expect-equivalence-result result "eqv" message 
			value 'arg argument warnobj))))

	;; without optional warning syntax
    ((_ msg val arg)
     (let ((message msg) (value val) (argument arg))
       (let ((result (test:_expect-eqv message value argument)))
	 	(test:make-expect-equivalence-result result "eqv" message 
			value 'arg argument))))))
					

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-equal: Expect the equal? relation to hold between val and arg
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define test:_expect-equal
  (lambda (msg val arg)
    (equal? val arg)))

(define-syntax expect-equal
  (syntax-rules (warn)

	;; with optional warning syntax
    ((_ msg (warn warning) val arg)
     (let ((warnobj warning) (message msg) (value val) (argument arg))
       (let ((result (test:_expect-equal message value argument)))
	 	(test:make-expect-equivalence-result result "equal" message 
			value 'arg argument warnobj))))

	;; without optional warning syntax
    ((_ msg val arg)
     (let ((message msg) (value val) (argument arg))
       (let ((result (test:_expect-equal message value argument)))
	 	(test:make-expect-equivalence-result result "equal" message 
			value 'arg argument))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-near: Expect a value within a certain tolerance
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define test:_expect-near
  (lambda (msg val tol arg)
    (< (abs (- val arg)) tol)))

(define-syntax expect-near
  (syntax-rules (warn)

	;; with optional warning syntax
    ((_ msg (warn warning) val tol arg)
     (let (	(warnobj warning) (message msg) (value val) (tolerance tol) 
	 		(argument arg))
       (let ((result (test:_expect-near message value tolerance argument)))
	 	(test:make-expect-tolerance-result result "near" message 
			value tol 'arg argument warnobj))))

	;; without optional warning syntax
    ((_ msg val tol arg)
     (let ((message msg) (value val) (tolerance tol) (argument arg))
       (let ((result (test:_expect-near message value tolerance argument)))
	 	(test:make-expect-tolerance-result result "near" message 
			value tol 'arg argument))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-positive: Expect a number to be positive
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define test:_expect-positive
  (lambda (msg val)
    (> val 0)))

(define-syntax expect-positive
  (syntax-rules (warn)

	;; with optional warning syntax
    ((_ msg (warn warning) val)
     (let ((warnobj warning) (message msg) (value val))
       (let ((result (test:_expect-positive message value)))
	 	(test:make-expect-result result "positive" message 'val value warnobj))))

	;; without optional warning syntax
    ((_ msg val)
     (let ((message msg) (value val))
       (let ((result (test:_expect-positive message value)))
	 	(test:make-expect-result result "positive" message 'val value))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; expect-negative: Expect a number to be negative.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define test:_expect-negative
  (lambda (msg val)
    (< val 0)))

(define-syntax expect-negative
  (syntax-rules (warn)

	;; with optional warning syntax
    ((_ msg (warn warning) val)
     (let ((warnobj warning) (message msg) (value val))
       (let ((result (test:_expect-negative message value)))
	 	(test:make-expect-result result "negative" message 'val value warnobj))))

	;; without optional warning syntax
    ((_ msg val)
     (let ((message msg) (value val))
       (let ((result (test:_expect-negative message value)))
	 	(test:make-expect-result result "negative" message 'val value))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Output analysis API functions. These functions take a result tree and
;; construct a "statistics" object which you can use to figure out how
;; many passed/failed packages, cases, and expectations their were. Plus
;; it sums how many warnings in each catagory, todos, and skips there were.
;; It returns a black box object that you use other API calls to pick apart.
;; NOTE: This function expects a a result tree rooted in a single package.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;
;; test:make-statistics
;; This function places the arguments passed to it into a black box statistics
;; object which is then returned.
;;;;;;;;;;;;;;;;;;
(define test:stat-make-statistics
	(lambda ()
		;; I care about 33 statistics, they are initialized to zero
		;; 0 - 32 indexes
		(make-vector 33 0)))

;;;;;;;;;;;;;;;;;;
;; This next macro and subsequent invocations describe the API by which you
;; may inspect a statistics object.
;;;;;;;;;;;;;;;;;;

;; Allow me to define all of the stats API functions that interact
;; with the black box statistics object. In this case, the black box is
;; a vector.
(define-syntax test:gen-stat-API-func
(syntax-rules (set incr decr ref)
	((_ set fname idx)
		(define fname 
			(lambda (statobj val)
				(vector-set! statobj val idx))))
	((_ incr fname idx)
		(define fname 
			(lambda (statobj)
				(vector-set! statobj idx (+ (vector-ref statobj idx) 1)))))
	((_ decr fname idx)
		(define fname 
			(lambda (statobj)
				(vector-set! statobj idx (- (vector-ref statobj idx) 1)))))
	((_ ref fname idx)
		(define fname 
			(lambda (statobj)
				(vector-ref statobj idx))))))

;;; XXX Ug, is there a better way to do this?

;; stat-packages
;; The number of test packages in a result tree
(test:gen-stat-API-func set stat-packages-set! 0)
(test:gen-stat-API-func incr stat-packages-incr! 0)
(test:gen-stat-API-func decr stat-packages-decr! 0)
(test:gen-stat-API-func ref stat-packages-ref 0)

;; stat-package-warnings
;; The number of warnings from all of the test packages in a result tree
(test:gen-stat-API-func set stat-package-warnings-set! 1)
(test:gen-stat-API-func incr stat-packages-warnings-incr! 1)
(test:gen-stat-API-func decr stat-package-warnings-decr! 1)
(test:gen-stat-API-func ref stat-package-warnings-ref 1)

;; stat-packages-passed
;; The number of test packages that are #t
(test:gen-stat-API-func set stat-packages-passed-set! 2)
(test:gen-stat-API-func incr stat-packages-passed-incr! 2)
(test:gen-stat-API-func decr stat-packages-passed-decr! 2)
(test:gen-stat-API-func ref stat-packages-passed-ref 2)

;; stat-packages-failed
;; The number of test packages that are #f
(test:gen-stat-API-func set stat-packages-failed-set! 3)
(test:gen-stat-API-func incr stat-packages-failed-incr! 3)
(test:gen-stat-API-func decr stat-packages-failed-decr! 3)
(test:gen-stat-API-func ref stat-packages-failed-ref 3)

;; stat-packages-terminated
;; The number of test packages that had a termination occur in the result tree
(test:gen-stat-API-func set stat-packages-terminated-set! 4)
(test:gen-stat-API-func incr stat-packages-terminated-incr! 4)
(test:gen-stat-API-func decr stat-packages-terminated-decr! 4)
(test:gen-stat-API-func ref stat-packages-terminated-ref 4)

;; stat-cases
;; The number of test cases in the result tree
(test:gen-stat-API-func set stat-cases-set! 5)
(test:gen-stat-API-func incr stat-cases-incr! 5)
(test:gen-stat-API-func decr stat-cases-decr! 5)
(test:gen-stat-API-func ref stat-cases-ref 5)

;; stat-case-warnings
;; The number of warnings from all of the test cases in a result tree
(test:gen-stat-API-func set stat-case-warnings-set! 6)
(test:gen-stat-API-func incr stat-case-warnings-incr! 6)
(test:gen-stat-API-func decr stat-case-warnings-decr! 6)
(test:gen-stat-API-func ref stat-case-warnings-ref 6)

;; stat-cases-passed
;; The number of test cases that were #t in the result tree
(test:gen-stat-API-func set stat-cases-passed-set! 7)
(test:gen-stat-API-func incr stat-cases-passed-incr! 7)
(test:gen-stat-API-func decr stat-cases-passed-decr! 7)
(test:gen-stat-API-func ref stat-cases-passed-ref 7)

;; stat-cases-failed
;; The number of test cases that were #f in the result tree
(test:gen-stat-API-func set stat-cases-failed-set! 8)
(test:gen-stat-API-func incr stat-cases-failed-incr! 8)
(test:gen-stat-API-func decr stat-cases-failed-decr! 8)
(test:gen-stat-API-func ref stat-cases-failed-ref 8)

;; stat-cases-terminated
;; The number of test cases that had a termination happen in the result tree
(test:gen-stat-API-func set stat-cases-failed-set! 9)
(test:gen-stat-API-func incr stat-cases-failed-incr! 9)
(test:gen-stat-API-func decr stat-cases-failed-decr! 9)
(test:gen-stat-API-func ref stat-cases-failed-ref 9)

;; stat-all-expectations
;; The number of all of the expectaions evaluated in the result tree
(test:gen-stat-API-func set stat-all-expectations-set! 10)
(test:gen-stat-API-func incr stat-all-expectations-incr! 10)
(test:gen-stat-API-func decr stat-all-expectations-decr! 10)
(test:gen-stat-API-func ref stat-all-expectations-ref 10)

;; stat-all-expectation-warnings
;; The number of all the warnings for all of the expectations in the result tree
(test:gen-stat-API-func set stat-all-expectation-warnings-set! 11)
(test:gen-stat-API-func incr stat-all-expectation-warnings-incr! 11)
(test:gen-stat-API-func decr stat-all-expectation-warnings-decr! 11)
(test:gen-stat-API-func ref stat-all-expectation-warnings-ref 11)

;; stat-all-expectations-passed
;; The number of all of the expectations that had passed  in the result tree
(test:gen-stat-API-func set stat-all-expectations-passed-set! 12)
(test:gen-stat-API-func incr stat-all-expectations-passed-incr! 12)
(test:gen-stat-API-func decr stat-all-expectations-passed-decr! 12)
(test:gen-stat-API-func ref stat-all-expectations-passed-ref 12)

;; stat-all-expectations-failed
;; The number of all of the expectations that had failed in the result tree
(test:gen-stat-API-func set stat-all-expectations-failed-set! 13)
(test:gen-stat-API-func incr stat-all-expectations-failed-incr! 13)
(test:gen-stat-API-func decr stat-all-expectations-failed-decr! 13)
(test:gen-stat-API-func ref stat-all-expectations-failed-ref 13)

;; stat-single-expectations
;; The number of single style expectations in the result tree
(test:gen-stat-API-func set stat-single-expectations-set! 14)
(test:gen-stat-API-func incr stat-single-expectations-incr! 14)
(test:gen-stat-API-func decr stat-single-expectations-decr! 14)
(test:gen-stat-API-func ref stat-single-expectations-ref 14)

;; stat-single-expectation-warnings
;; The number of single style expectations with warnings in the result tree
(test:gen-stat-API-func set stat-single-expectation-warnings-set! 15)
(test:gen-stat-API-func incr stat-single-expectation-warnings-incr! 15)
(test:gen-stat-API-func decr stat-single-expectation-warnings-decr! 15)
(test:gen-stat-API-func ref stat-single-expectation-warnings-ref 15)

;; stat-single-expectations-passed
;; The number of single style expectations that passed in the result tree
(test:gen-stat-API-func set stat-single-expectations-passed-set! 16)
(test:gen-stat-API-func incr stat-single-expectations-passed-incr! 16)
(test:gen-stat-API-func decr stat-single-expectations-passed-decr! 16)
(test:gen-stat-API-func ref stat-single-expectations-passed-ref 16)

;; stat-single-expectations-failed
;; The number of single style expectations that had failed in the result tree
(test:gen-stat-API-func set stat-single-expectations-failed-set! 17)
(test:gen-stat-API-func incr stat-single-expectations-failed-incr! 17)
(test:gen-stat-API-func decr stat-single-expectations-failed-decr! 17)
(test:gen-stat-API-func ref stat-single-expectations-failed-ref 17)

;; stat-tol-expectations
;; The number of tolerance style expectations in the result tree
(test:gen-stat-API-func set stat-tol-expectations-set! 18)
(test:gen-stat-API-func incr stat-tol-expectations-incr! 18)
(test:gen-stat-API-func decr stat-tol-expectations-decr! 18)
(test:gen-stat-API-func ref stat-tol-expectations-ref 18)

;; stat-tol-expectation-warnings
;; The number of tolerance expectations that had warnings in the tree
(test:gen-stat-API-func set stat-tol-expectation-warnings-set! 19)
(test:gen-stat-API-func incr stat-tol-expectation-warnings-incr! 19)
(test:gen-stat-API-func decr stat-tol-expectation-warnings-decr! 19)
(test:gen-stat-API-func ref stat-tol-expectation-warnings-ref 19)

;; stat-tol-expectations-passed
;; The number of tolerance style expectations that passed in the result tree
(test:gen-stat-API-func set stat-tol-expectations-passed-set! 20)
(test:gen-stat-API-func incr stat-tol-expectations-passed-incr! 20)
(test:gen-stat-API-func decr stat-tol-expectations-passed-decr! 20)
(test:gen-stat-API-func ref stat-tol-expectations-passed-ref 20)

;; stat-tol-expectations-failed
;; The number of tolerance style expectations that failed in the result tree
(test:gen-stat-API-func set stat-tol-expectations-failed-set! 21)
(test:gen-stat-API-func incr stat-tol-expectations-failed-incr! 21)
(test:gen-stat-API-func decr stat-tol-expectations-failed-decr! 21)
(test:gen-stat-API-func ref stat-tol-expectations-failed-ref 21)

;; stat-equiv-expectations
;; The number of equivalence style expectations in the result tree
(test:gen-stat-API-func set stat-equiv-expectations-set! 22)
(test:gen-stat-API-func incr stat-equiv-expectations-incr! 22)
(test:gen-stat-API-func decr stat-equiv-expectations-decr! 22)
(test:gen-stat-API-func ref stat-equiv-expectations-ref 22)

;; stat-equiv-expectation-warnings
;; The number of tolerance expectations that had warnings in the tree
(test:gen-stat-API-func set stat-equiv-expectation-warnings-set! 23)
(test:gen-stat-API-func incr stat-equiv-expectation-warnings-incr! 23)
(test:gen-stat-API-func decr stat-equiv-expectation-warnings-decr! 23)
(test:gen-stat-API-func ref stat-equiv-expectation-warnings-ref 23)

;; stat-equiv-expectations-passed
;; The number of tolerance expectations that failed in the result tree
(test:gen-stat-API-func set stat-equiv-expectations-passed-set! 24)
(test:gen-stat-API-func incr stat-equiv-expectations-passed-incr! 24)
(test:gen-stat-API-func decr stat-equiv-expectations-passed-decr! 24)
(test:gen-stat-API-func ref stat-equiv-expectations-passed-ref 24)

;; stat-equiv-expectations-failed
;; The number of tolerance expectations that failed in the result tree
(test:gen-stat-API-func set stat-equiv-expectations-failed-set! 25)
(test:gen-stat-API-func incr stat-equiv-expectations-failed-incr! 25)
(test:gen-stat-API-func decr stat-equiv-expectations-failed-decr! 25)
(test:gen-stat-API-func ref stat-equiv-expectations-failed-ref 25)

;; stat-todos
;; The number of todos in the result tree
(test:gen-stat-API-func set stat-todos-set! 26)
(test:gen-stat-API-func incr stat-todos-incr! 26)
(test:gen-stat-API-func decr stat-todos-decr! 26)
(test:gen-stat-API-func ref stat-todos-ref 26)

;; stat-todo-warnings
;; The number of todos with warnings in the result tree
(test:gen-stat-API-func set stat-todo-warnings-set! 27)
(test:gen-stat-API-func incr stat-todo-warnings-incr! 27)
(test:gen-stat-API-func decr stat-todo-warnings-decr! 27)
(test:gen-stat-API-func ref stat-todo-warnings-ref 27)

;; stat-skips
;; The number of skips in the result tree
(test:gen-stat-API-func set stat-skips-set! 28)
(test:gen-stat-API-func incr stat-skips-incr! 28)
(test:gen-stat-API-func decr stat-skips-decr! 28)
(test:gen-stat-API-func ref stat-skips-ref 28)

;; stat-skip-warnings
;; The number of skips with warnings in the result tree
(test:gen-stat-API-func set stat-skip-warnings-set! 29)
(test:gen-stat-API-func incr stat-skip-warnings-incr! 29)
(test:gen-stat-API-func decr stat-skip-warnings-decr! 29)
(test:gen-stat-API-func ref stat-skip-warnings-ref 29)

;; stat-glosses
;; The number of glosses in the result tree
(test:gen-stat-API-func set stat-glosses-set! 30)
(test:gen-stat-API-func incr stat-glosses-incr! 30)
(test:gen-stat-API-func decr stat-glosses-decr! 30)
(test:gen-stat-API-func ref stat-glosses-ref 30)

;; stat-gloss-warnings
;; The number of glosses with warnings in the result tree
(test:gen-stat-API-func set stat-gloss-warnings-set! 31)
(test:gen-stat-API-func incr stat-gloss-warnings-incr! 31)
(test:gen-stat-API-func decr stat-gloss-warnings-decr! 31)
(test:gen-stat-API-func ref stat-gloss-warnings-ref 31)

;; stat-terminations
;; The number of terminations in the result tree
(test:gen-stat-API-func set stat-terminations-set! 32)
(test:gen-stat-API-func incr stat-terminations-incr! 32)
(test:gen-stat-API-func decr stat-terminations-decr! 32)
(test:gen-stat-API-func ref stat-terminations-ref 32)


;;;;;;;;;;;;;;;;;;
;; stat-compute-statistics
;; This function walks a result tree and returns a statistics object which you
;; may query with the above API.
;; NOTE: This function expects a result tree rooted in a single test package.
;;;;;;;;;;;;;;;;;;

(define stat-compute-statistics
(lambda (resnode)
	(let ((stats (test:stat-make-statistics)))
		;; tally walks the result tree and sums up the various catagories of
		;; things I care about for each type of result object.
		(letrec ((tally
			(lambda (resnode)
				(cond
					;; compute statistics about a package result
					((test-package-result? resnode)

						;; count the package object
						(stat-packages-incr! stats)

						;; count the success or failure of it
						(if (equal? #t (test-package-result-result-ref resnode))
							(stat-packages-passed-incr! stats)
							(stat-packages-failed-incr! stats))

						;; count the warning if one exists.
						(cond
							((test-package-result-warning? resnode)
								(stat-package-warnings-incr! stats)))

						;; now, compute the statistics of everything inside the
						;; test package
						(for-each 
							(lambda (node) (tally node))
							(test-package-result-exps-ref resnode)))

					;; compute statistics about a case result
					((test-case-result? resnode)

						;; count the case object
						(stat-cases-incr! stats)

						;; count the success or failure of it
						(if (equal? #t (test-case-result-result-ref resnode))
							(stat-cases-passed-incr! stats)
							(stat-cases-failed-incr! stats))

						;; count the warning if one exists.
						(cond
							((test-case-result-warning? resnode)
								(stat-case-warnings-incr! stats)))

						;; now, compute the statistics of everything inside the
						;; test case
						(for-each 
							(lambda (node) (tally node))
							(test-case-result-expectations-ref resnode)))

					;; count the statistics about a single styled expectation
					((expect-result? resnode)
						;; count the expectation generally
						(stat-all-expectations-incr! stats)
						;; count the expectation specifically
						(stat-single-expectations-incr! stats)

						;; count if it passed or succeeded
						(if (equal? #t (expect-result-result-ref resnode))
							(begin
								(stat-all-expectations-passed-incr! stats)
								(stat-single-expectations-passed-incr! stats))
							(begin
								(stat-all-expectations-failed-incr! stats)
								(stat-single-expectations-failed-incr! stats)))

						;; count any warnings
						(cond
							((expect-result-warning? resnode)
								(stat-all-expectation-warnings-incr! stats)
								(stat-single-expectation-warnings-incr! stats))))

					;; count the statistics about a tolerance styled expectation
					((expect-tolerance-result? resnode)
						;; count the expectation generally
						(stat-all-expectations-incr! stats)
						;; count the expectation specifically
						(stat-tol-expectations-incr! stats)

						;; count if it passed or succeeded
						(if (equal? #t (expect-tolerance-result-result-ref resnode))
							(begin
								(stat-all-expectations-passed-incr! stats)
								(stat-tol-expectations-passed-incr! stats))
							(begin
								(stat-all-expectations-failed-incr! stats)
								(stat-tol-expectations-failed-incr! stats)))

						;; count any warnings
						(cond
							((expect-tolerance-result-warning? resnode)
								(stat-all-expectation-warnings-incr! stats)
								(stat-tol-expectation-warnings-incr! stats))))

					;; count the statistics about an equivalence styled 
					;; expectation
					((expect-equivalence-result? resnode)
						;; count the expectation generally
						(stat-all-expectations-incr! stats)
						;; count the expectation specifically
						(stat-equiv-expectations-incr! stats)

						;; count if it passed or succeeded
						(if (equal? #t (expect-equivalence-result-result-ref resnode))
							(begin
								(stat-all-expectations-passed-incr! stats)
								(stat-equiv-expectations-passed-incr! stats))
							(begin
								(stat-all-expectations-failed-incr! stats)
								(stat-equiv-expectations-failed-incr! stats)))

						;; count any warnings
						(cond
							((expect-equivalence-result-warning? resnode)
								(stat-all-expectation-warnings-incr! stats)
								(stat-equiv-expectation-warnings-incr! stats))))

					;; count the terminations and where they happened
					((terminate-result? resnode)
						;; count it
						(stat-terminations-incr! stats)

						;; figure out the scope and count it in the right one
						(cond
							((equal? 'test-case 
									(temination-result-container-ref resnode))
								(stat-cases-terminated-incr! stats))

							((equal? 'test-package
									(temination-result-container-ref resnode))
								(stat-packages-terminated-incr! stats))))
								


					;; even count stuff like glosses and warnings in them
					((gloss-result? resnode)
						;; count it
						(stat-glosses-incr! stats)

						;; count any warnings
						(cond
							((gloss-result-warning? resnode)
								(stat-gloss-warnings-incr! stats))))


					;; count how many todos there are and warnings
					((todo-result? resnode)
						;; count it
						(stat-todos-incr! stats)

						;; count any warnings
						(cond
							((todo-result-warning? resnode)
								(stat-todo-warnings-incr! stats))))

					;; count how many skips there are and warnings
					((skip-result? resnode)
						;; count it
						(stat-skips-incr! stats)

						;; count any warnings
						(cond
							((skip-result-warning? resnode)
								(stat-skip-warnings-incr! stats))))

					;; dump an error if passed something I don't know about.
					(else
					(printnl "*** Error in compute-result-statistics")
					(printnl "	Unknown result node!: " resnode))))))

				(tally resnode)
				stats))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Output generation functions. These functions take a result tree and emit
;; human readable, html, whatever else you want. Here I've supplied a 
;; simple one which just emits human readable output. This is a simple
;; generator which only accepts ONE toplevel result tree.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; indent the number of spaces required
(define test:indent
  (lambda (spaces)
    (let loop ((tpi spaces))
      (if (zero? tpi)
	  #t
	  (begin
	    (display " ")
	    (loop (- tpi 1)))))))


;; define the usually wanted display with multiple arguments and newline at the
;; end.
(define printnl
	(lambda args
		(for-each (lambda (out) (display out)) args)
		(newline)))

;; define the usually wanted display with multiple arguments and no newline at
;; the end.
(define printme
	(lambda args
		(for-each (lambda (out) (display out)) args)))

;; print something at an indention level
(define printinl
	(lambda (indent . args)
		(test:indent indent)
		(apply printnl args)))

;; print something at an indention level
(define printime
	(lambda (indent . args)
		(test:indent indent)
		(apply printme args)))

;; dump out simple human readable output for a result tree, and return the
;; boolean result of the root.
(define output-human-simple
(lambda (resnode)
(letrec ((xlate
	(lambda (indent resnode)

		(cond
		;; print out a package result
		((test-package-result? resnode)

			(printinl indent 
				"Begin Package: " (test-package-result-message-ref resnode))

			;; dump out any warnings...
			(cond ((test-package-result-warning? resnode)
				(printinl indent "WARNING: " 
					(test-package-result-warning-ref resnode))))
					
			;; process each evaluated object held in the test package
			(for-each 
				(lambda (node) (xlate (+ indent 2) node))
				(test-package-result-exps-ref resnode))

			(printinl indent
				"Result: " (test-package-result-result-ref resnode))
			(printinl indent 
				"End Package: " (test-package-result-message-ref resnode))
			(newline))

		;; print out a test-case result
		((test-case-result? resnode)
			(printinl indent 
				"Begin Test Case: " (test-case-result-message-ref resnode))

			;; dump out any warnings...
			(cond ((test-case-result-warning? resnode)
				(printinl indent "WARNING: " 
					(test-case-result-warning-ref resnode))))

			;; process each expectation result.
			(for-each 
				(lambda (node) (xlate (+ indent 2) node))
				(test-case-result-expectations-ref resnode))
			(printinl indent "Result: " (test-case-result-result-ref resnode))
			(printinl indent 
				"End Test Case: " (test-case-result-message-ref resnode))
			(newline))

		;; print out an expect-result
		((expect-result? resnode)
			(printinl indent 
				"Begin Expectation: " (expect-result-message-ref resnode))
			(printinl indent "Expect " (expect-result-specific-ref resnode))

			;; dump out any warnings...
			(cond ((expect-result-warning? resnode)
				(printinl indent "WARNING: " 
					(expect-result-warning-ref resnode))))

			(printinl (+ indent 2) "Unevaluated: ")
			(printinl (+ indent 2) (expect-result-unevaled-ref resnode))
			(printinl (+ indent 2) "Evaluated: ")
			(printinl (+ indent 2) (expect-result-evaled-ref resnode))
			(printinl indent "Result: " (expect-result-result-ref resnode))
			(printinl indent 
				"End Expectation: " (expect-result-message-ref resnode))
			(newline))

		;; print out an expect-tolerance-result
		((expect-tolerance-result? resnode)
			(printinl indent 
				"Begin Expectation: " 
					(expect-tolerance-result-message-ref resnode))
			(printinl indent "Expect " 
				(expect-tolerance-result-specific-ref resnode))

			;; dump out any warnings...
			(cond ((expect-tolerance-result-warning? resnode)
				(printinl indent "WARNING: " 
					(expect-tolerance-result-warning-ref resnode))))

			(printinl (+ indent 2) "Expected Value: ")
			(printinl (+ indent 2) 
				(expect-tolerance-result-lhs-evaled-ref resnode))
			(printinl (+ indent 2) "Expected Tolerance: ")
			(printinl (+ indent 2) 
				(expect-tolerance-result-lhs-tol-evaled-ref resnode))
			(printinl (+ indent 2) "Unevaluated: ")
			(printinl (+ indent 2) 
				(expect-tolerance-result-rhs-unevaled-ref resnode))
			(printinl (+ indent 2) "Evaluated: ")
			(printinl (+ indent 2) 
				(expect-tolerance-result-rhs-evaled-ref resnode))
			(printinl indent "Result: " 
				(expect-tolerance-result-result-ref resnode))

			(printinl indent 
				"End Expectation: " 
					(expect-tolerance-result-message-ref resnode))
			(newline))

		;; print out an expect-equivalence-result
		((expect-equivalence-result? resnode)
			(printinl indent 
				"Begin Expectation: " 
					(expect-equivalence-result-message-ref resnode))
			(printinl indent "Expect " 
				(expect-equivalence-result-specific-ref resnode))

			;; dump out any warnings...
			(cond ((expect-equivalence-result-warning? resnode)
				(printinl indent "WARNING: " 
					(expect-equivalence-result-warning-ref resnode))))

			(printinl (+ indent 2) "Expected Value: ")
			(printinl (+ indent 2) 
				(expect-equivalence-result-lhs-evaled-ref resnode))
			(printinl (+ indent 2) "Unevaluated: ")
			(printinl (+ indent 2) 
				(expect-equivalence-result-rhs-unevaled-ref resnode))
			(printinl (+ indent 2) "Evaluated: ")
			(printinl (+ indent 2) 
				(expect-equivalence-result-rhs-evaled-ref resnode))
			(printinl indent "Result: " 
				(expect-equivalence-result-result-ref resnode))

			(printinl indent 
				"End Expectation: " 
					(expect-equivalence-result-message-ref resnode))
			(newline))

		;; print out a user-invoked termination result
		((terminate-result? resnode)
			(printinl indent "Begin TERMINATION")
			(printinl (+ indent 2)
				"Message: " (terminate-result-message-ref resnode))
			(printinl (+ indent 2)
				"Container: " (terminate-result-container-ref resnode))
			(printinl (+ indent 2)
				"Scope: " (terminate-result-scope-ref resnode))
			(printinl indent
				"Result: " (terminate-result-result-ref resnode))
			(printinl indent "End TERMINATION")
			(newline))

		;; print out any gloss message the user might have inserted somewhere.
		((gloss-result? resnode)
			(printinl indent "GLOSS: " (gloss-result-message-ref resnode))
			;; dump out any warnings...
			(cond ((gloss-result-warning? resnode)
				(printinl indent "WARNING: " 
					(gloss-result-warning-ref resnode))))
			(printinl indent ""))

		;; print out any todo message the user might have inserted somewhere.
		((todo-result? resnode)
			(printinl indent "TODO: " (todo-result-message-ref resnode))
			;; dump out any warnings...
			(cond ((todo-result-warning? resnode)
				(printinl indent "WARNING: " 
					(todo-result-warning-ref resnode))))
			(printinl indent ""))

		;; print out any skipped thing the user may have done.
		((skip-result? resnode)
			(printinl indent "SKIP: " (skip-result-message-ref resnode))
			;; dump out any warnings...
			(cond ((skip-result-warning? resnode)
				(printinl indent "WARNING: " 
					(skip-result-warning-ref resnode))))
			(printinl indent ""))

		(else
			(printinl indent "*** Error: Unknown result node!: " resnode))))))

	;; figure out if I was passed the right stuff, die of not.
	(cond 
		((test-package-result? resnode)
			;; spew out the tree
			;; start the translation at column zero
			(xlate 0 resnode)
			(if (equal? #t (test-package-result-result-ref resnode))
				(printnl "ALL TESTS SUCCESSFUL!")
				(printnl "SOME TESTS FAILED!"))
			;; return the toplevel package result to the caller
			(test-package-result-result-ref resnode))
		(else
			(display "You did not pass (output-style-human ...) a valid ")
			(display "test package result tree.") 
			(newline))))))


;; dump out simple html readable output for a result tree, and return the
;; boolean result of the root. This function is very big, mostly because it
;; has some helper functions inside it to do the work, and one big translation
;; function that I didn't want available except to this function.
(define output-html-simple
(lambda (resnode)
(letrec (
	;; some html tag creation helpers
	(begin-anchor
		(lambda (str)
			(string-append str "_begin")))
	(end-anchor
		(lambda (str)
			(string-append str "_end")))

	;; this function spits out the entire result tree in html with anchor
	;; tags, and color coding.
	;; XXX Eh, this code could be better written, but I don't want to design
	;; and build a whole HTML package just to do it nicely.
	(xlate 
	(lambda (indent resnode)
		(cond
		;; print out a package result
		((test-package-result? resnode)
			(printinl indent "<dl>")

			(printinl indent "<dt>")
			;; print out "Begin Package:" with anchors and links set up nice
			(printme 
				"<a name=\"" (begin-anchor (test-package-result-id-ref resnode))
				"\"> "
				"<a href=\"#" (end-anchor (test-package-result-id-ref resnode))
				"\"> Begin Package: </a> </a> ")

			;; print out the message from this package, color coded for 
			;; success or failure.
			(printnl 
				(if (equal? #t (test-package-result-result-ref resnode))
					"<font color=#66cc66> "
					"<font color=#cc6666> ")
				(test-package-result-message-ref resnode) 
				" </font>")
			(printinl indent "</dt>")

			;; dump out any warnings...
			(cond ((test-package-result-warning? resnode)
					(printinl indent "<dt>")
					(printinl indent "<font color=#cccc66>")
					(printinl indent "WARNING: " 
						(test-package-result-warning-ref resnode))
					(printinl indent "</font>")
					(printinl indent "</dt>")))
			(printinl indent "<br>")

			;; process each evaluated object held in the test package
			(for-each 
				(lambda (node) (xlate (+ indent 2) node))
				(test-package-result-exps-ref resnode))

			(printinl indent "<dt>")
			;; print out "Result: " with the color of success or failure
			(if (equal? #t (test-package-result-result-ref resnode))
				(printime indent
					"<font color=#66cc66> Result: ")
				(printime indent
					"<font color=#cc6666> Result: "))

			;; now print the actual boolean representing the result
			(printnl 
				(test-package-result-result-ref resnode) " </font>")
			(printinl indent "</dt>")

			(printinl indent "<dt>")
			;; Print the "End Package:" message knowing it is not only the
			;; anchor for the bottom of the test package, but also a link to
			;; the top of the package.
			(printime indent 
				"<a name=\"" 
				(end-anchor (test-package-result-id-ref resnode))
				"\"> "
				"<a href=\"#"
				(begin-anchor (test-package-result-id-ref resnode))
				"\"> End Package: </a> </a>")

			;; print out the name of the package colored for success or failure.
			(printnl 
				(if (equal? #t (test-package-result-result-ref resnode))
					"<font color=#66cc66> "
					"<font color=#cc6666> ")
				(test-package-result-message-ref resnode) 
				" </font>")
			(printinl indent "</dt>")

			(printinl indent "<br>")
			(printinl indent "</dl>"))

		;; print out a test-case result
		((test-case-result? resnode)
			(printinl indent "<dl>")

			(printinl indent "<dt>")
			;; print out "Begin Test Case:" with anchors and links set up nice
			(printme 
				"<a name=\"" (begin-anchor (test-case-result-id-ref resnode))
				"\"> "
				"<a href=\"#" (end-anchor (test-case-result-id-ref resnode))
				"\"> Begin Test Case: </a> </a> ")

			;; print out the message from this package, color coded for 
			;; success or failure.
			(printnl 
				(if (equal? #t (test-case-result-result-ref resnode))
					"<font color=#66cc66> "
					"<font color=#cc6666> ")
				(test-case-result-message-ref resnode) 
				" </font>")
			(printinl indent "</dt>")


			;; dump out any warnings...
			(cond ((test-case-result-warning? resnode)
					(printinl indent "<dt>")
					(printinl indent "<font color=#cccc66>")
					(printinl indent "WARNING: " 
						(test-case-result-warning-ref resnode))
					(printinl indent "</font>")
					(printinl indent "</dt>")))
			(printinl indent "<br>")

			;; process each expectation result.
			(for-each 
				(lambda (node) (xlate (+ indent 2) node))
				(test-case-result-expectations-ref resnode))

			(printinl indent "<dt>")
			;; print out "Result: " with the color of success or failure
			(if (equal? #t (test-case-result-result-ref resnode))
				(printime indent
					"<font color=#66cc66> Result: ")
				(printime indent
					"<font color=#cc6666> Result: "))

			;; now print the actual boolean representing the result
			(printnl 
				(test-case-result-result-ref resnode) " </font>")
			(printinl indent "</dt>")

			(printinl indent "<dt>")
			;; Print the "End Test Case:" message knowing it is not only the
			;; anchor for the bottom of the test case, but also a link to
			;; the top of the test case.
			(printime indent 
				"<a name=\"" 
				(end-anchor (test-case-result-id-ref resnode))
				"\"> "
				"<a href=\"#"
				(begin-anchor (test-case-result-id-ref resnode))
				"\"> End Test Case: </a> </a>")

			;; print out the name of the package colored for success or failure.
			(printnl 
				(if (equal? #t (test-case-result-result-ref resnode))
					"<font color=#66cc66> "
					"<font color=#cc6666> ")
				(test-case-result-message-ref resnode) 
				" </font>")
			(printinl indent "</dt>")

			(printinl indent "</dl>")
			(printinl indent "<br>"))

		;; print out an expect-result
		((expect-result? resnode)
			(printinl indent "<dl>")

			(printinl indent "<dt>")
			(printme 
				"<a name=\"" (begin-anchor (expect-result-id-ref resnode))
				"\"> "
				"<a href=\"#" (end-anchor (expect-result-id-ref resnode))
				"\"> Begin Expectation: </a> </a> ")
			;; print out the message from this expectation, color coded for 
			;; success or failure.
			(printnl 
				(if (equal? #t (expect-result-result-ref resnode))
					"<font color=#66cc66> "
					"<font color=#cc6666> ")
				(expect-result-message-ref resnode) 
				" </font>")
			(printinl indent "</dt>")


			;; dump out any warnings...
			(cond ((expect-result-warning? resnode)
				(printinl indent "<dt>")
				(printinl indent "<font color=#cccc66>")
				(printinl indent "WARNING: " 
					(expect-result-warning-ref resnode))
				(printinl indent "</font>")
				(printinl indent "</dt>")))

			;; print the specific type of single style expectation this was
			(printinl indent 
				"<dt> Expect " (expect-result-specific-ref resnode) "</dt>")

			(printinl indent "<dl>")

			(printinl indent "<dt> Unevaluated: </dt>")
			(printinl indent "<dl>")
			(printinl indent 
				"<dt> " (expect-result-unevaled-ref resnode) " </dt>")
			(printinl indent "</dl>")

			(printinl indent "<dt> Evaluated: </dt>")
			(printinl indent "<dl>")
			(printinl indent 
				"<dt> " (expect-result-evaled-ref resnode) " </dt>")
			(printinl indent "</dl>")

			(printinl indent "</dl>")

			(printinl indent "<dt>")
			(if (equal? #t (expect-result-result-ref resnode))
				(printime indent
					"<font color=#66cc66> Result: ")
				(printime indent
					"<font color=#cc6666> Result: "))

			;; now print the actual boolean representing the result
			(printnl 
				(expect-result-result-ref resnode) " </font>")
			(printinl indent "</dt>")

			(printinl indent "<dt>")
			;; Print the "End Expectation:" message knowing it is not only the
			;; anchor for the bottom of the expectation, but also a link to
			;; the top of the expectation
			(printime indent 
				"<a name=\"" 
				(end-anchor (expect-result-id-ref resnode))
				"\"> "
				"<a href=\"#"
				(begin-anchor (expect-result-id-ref resnode))
				"\"> End Expectation: </a> </a>")

			;; print out the name of the expectation colored for 
			;; success or failure.
			(printnl 
				(if (equal? #t (expect-result-result-ref resnode))
					"<font color=#66cc66> "
					"<font color=#cc6666> ")
				(expect-result-message-ref resnode) 
				" </font>")
			(printinl indent "</dt>")

			(printinl indent "</dl>")
			(printinl indent "<br>"))

		;; print out an expect-tolerance-result
		((expect-tolerance-result? resnode)
			(printinl indent "<dl>")

			(printinl indent "<dt>")
			(printme 
				"<a name=\"" 
				(begin-anchor (expect-tolerance-result-id-ref resnode))
				"\"> "
				"<a href=\"#" 
				(end-anchor (expect-tolerance-result-id-ref resnode))
				"\"> Begin Expectation: </a> </a> ")
			;; print out the message from this expectation, color coded for 
			;; success or failure.
			(printnl 
				(if (equal? #t (expect-tolerance-result-result-ref resnode))
					"<font color=#66cc66> "
					"<font color=#cc6666> ")
				(expect-tolerance-result-message-ref resnode) 
				" </font>")
			(printinl indent "</dt>")

			;; dump out any warnings...
			(cond ((expect-tolerance-result-warning? resnode)
				(printinl indent "<dt>")
				(printinl indent "<font color=#cccc66>")
				(printinl indent "WARNING: " 
					(expect-tolerance-result-warning-ref resnode))
				(printinl indent "</font>")
				(printinl indent "</dt>")))

			(printinl indent "<dt>")
			(printinl indent "Expect " 
				(expect-tolerance-result-specific-ref resnode))
			(printinl indent "</dt>")

			(printinl indent "<dl>")

			(printinl indent "<dt>")
			(printinl indent "Expected Value: ")
			(printinl indent "</dt>")
			(printinl indent "<dl>")
			(printinl indent "<dt>")
			(printinl indent 
				(expect-tolerance-result-lhs-evaled-ref resnode))
			(printinl indent "</dt>")
			(printinl indent "</dl>")

			(printinl indent "<dt>")
			(printinl indent "Expected Tolerance: ")
			(printinl indent "</dt>")
			(printinl indent "<dl>")
			(printinl indent "<dt>")
			(printinl indent 
				(expect-tolerance-result-lhs-tol-evaled-ref resnode))
			(printinl indent "</dt>")
			(printinl indent "</dl>")

			(printinl indent "<dt>")
			(printinl indent "Unevaluated: ")
			(printinl indent "</dt>")
			(printinl indent "<dl>")
			(printinl indent "<dt>")
			(printinl indent 
				(expect-tolerance-result-rhs-unevaled-ref resnode))
			(printinl indent "</dt>")
			(printinl indent "</dl>")

			(printinl indent "<dt>")
			(printinl indent "Evaluated: ")
			(printinl indent "</dt>")
			(printinl indent "<dl>")
			(printinl indent "<dt>")
			(printinl indent 
				(expect-tolerance-result-rhs-evaled-ref resnode))
			(printinl indent "</dt>")
			(printinl indent "</dl>")
			(printinl indent "</dl>")

			(printinl indent "<dt>")
			;; print the result, color coded.
			(if (equal? #t (expect-tolerance-result-result-ref resnode))
				(printime indent
					"<font color=#66cc66> Result: ")
				(printime indent
					"<font color=#cc6666> Result: "))

			;; now print the actual boolean representing the result
			(printnl 
				(expect-tolerance-result-result-ref resnode) " </font>")
			(printinl indent "</dt>")

			(printinl indent "<dt>")
			;; Print the "End Expectation:" message knowing it is not only the
			;; anchor for the bottom of the expectation, but also a link to
			;; the top of the expectation
			(printime indent 
				"<a name=\"" 
				(end-anchor (expect-tolerance-result-id-ref resnode))
				"\"> "
				"<a href=\"#"
				(begin-anchor (expect-tolerance-result-id-ref resnode))
				"\"> End Expectation: </a> </a>")

			;; print out the name of the expectation colored for 
			;; success or failure.
			(printnl 
				(if (equal? #t (expect-tolerance-result-result-ref resnode))
					"<font color=#66cc66> "
					"<font color=#cc6666> ")
				(expect-tolerance-result-message-ref resnode) 
				" </font>")
			(printinl indent "</dt>")

			(printinl indent "</dl>")
			(printinl indent "<br>"))
		

		;; print out an expect-equivalence-result
		((expect-equivalence-result? resnode)
			(printinl indent "<dl>")

			(printinl indent "<dt>")
			(printme 
				"<a name=\"" 
				(begin-anchor (expect-equivalence-result-id-ref resnode))
				"\"> "
				"<a href=\"#" 
				(end-anchor (expect-equivalence-result-id-ref resnode))
				"\"> Begin Expectation: </a> </a> ")
			;; print out the message from this expectation, color coded for 
			;; success or failure.
			(printnl 
				(if (equal? #t (expect-equivalence-result-result-ref resnode))
					"<font color=#66cc66> "
					"<font color=#cc6666> ")
				(expect-equivalence-result-message-ref resnode) 
				" </font>")
			(printinl indent "</dt>")

			;; dump out any warnings...
			(cond ((expect-equivalence-result-warning? resnode)
				(printinl indent "<dt>")
				(printinl indent "<font color=#cccc66>")
				(printinl indent "WARNING: " 
					(expect-equivalence-result-warning-ref resnode))
				(printinl indent "</font>")
				(printinl indent "</dt>")))

			(printinl indent "<dt>")
			(printinl indent "Expect " 
				(expect-equivalence-result-specific-ref resnode))
			(printinl indent "</dt>")

			(printinl indent "<dl>")

			(printinl indent "<dt>")
			(printinl indent "Expected Value: ")
			(printinl indent "</dt>")
			(printinl indent "<dl>")
			(printinl indent "<dt>")
			(printinl indent
				(expect-equivalence-result-lhs-evaled-ref resnode))
			(printinl indent "</dt>")
			(printinl indent "</dl>")

			(printinl indent "<dt>")
			(printinl indent "Unevaluated: ")
			(printinl indent "</dt>")
			(printinl indent "<dl>")
			(printinl indent "<dt>")
			(printinl indent 
				(expect-equivalence-result-rhs-unevaled-ref resnode))
			(printinl indent "</dt>")
			(printinl indent "</dl>")

			(printinl indent "<dt>")
			(printinl indent "Evaluated: ")
			(printinl indent "</dt>")
			(printinl indent "<dl>")
			(printinl indent "<dt>")
			(printinl indent 
				(expect-equivalence-result-rhs-evaled-ref resnode))
			(printinl indent "</dt>")
			(printinl indent "</dl>")

			(printinl indent "</dl>")

			(printinl indent "<dt>")
			;; print the result, color coded.
			(if (equal? #t (expect-equivalence-result-result-ref resnode))
				(printime indent
					"<font color=#66cc66> Result: ")
				(printime indent
					"<font color=#cc6666> Result: "))

			;; now print the actual boolean representing the result
			(printnl 
				(expect-equivalence-result-result-ref resnode) " </font>")
			(printinl indent "</dt>")

			(printinl indent "<dt>")
			;; Print the "End Expectation:" message knowing it is not only the
			;; anchor for the bottom of the expectation, but also a link to
			;; the top of the expectation
			(printime indent 
				"<a name=\"" 
				(end-anchor (expect-equivalence-result-id-ref resnode))
				"\"> "
				"<a href=\"#"
				(begin-anchor (expect-equivalence-result-id-ref resnode))
				"\"> End Expectation: </a> </a>")

			;; print out the name of the expectation colored for 
			;; success or failure.
			(printnl 
				(if (equal? #t (expect-equivalence-result-result-ref resnode))
					"<font color=#66cc66> "
					"<font color=#cc6666> ")
				(expect-equivalence-result-message-ref resnode) 
				" </font>")
			(printinl indent "</dt>")

			(printinl indent "</dl>")
			(printinl indent "<br>"))


		;; print out a user-invoked termination result
		((terminate-result? resnode)
			(printinl indent "<dl>")
			(printinl indent "<dt>")
			(printinl indent "Begin TERMINATION")
			(printinl indent "</dt>")

			(printinl indent "<dl>")
			(printinl indent "<dt>")
			(printinl indent
				"Message: " (terminate-result-message-ref resnode))
			(printinl indent "</dt>")

			(printinl indent "<dt>")
			(printinl indent
				"Container: " (terminate-result-container-ref resnode))
			(printinl indent "</dt>")

			(printinl indent "<dt>")
			(printinl indent
				"Scope: " (terminate-result-scope-ref resnode))
			(printinl indent "</dt>")

			(printinl indent "</dl>")

			(printinl indent "<dt>")
			(printinl indent
				"Result: " (terminate-result-result-ref resnode))
			(printinl indent "</dt>")

			(printinl indent "<dt>")
			(printinl indent "End TERMINATION")
			(printinl indent "</dt>")
			(printinl indent "</dl>"))

		;; print out any gloss message the user might have inserted somewhere.
		((gloss-result? resnode)
			(printinl indent "<dl>")
			(printinl indent "<dt>")
			(printinl indent "GLOSS: " (gloss-result-message-ref resnode))
			(printinl indent "</dt>")
			;; dump out any warnings...
			(cond ((gloss-result-warning? resnode)
				(printinl indent "<dt>")
				(printinl indent "<font color=#cccc66>")
				(printinl indent "WARNING: " 
					(gloss-result-warning-ref resnode))
				(printinl indent "</font>")
				(printinl indent "</dt>")))

			(printinl indent "</dl>"))

		;; print out any todo message the user might have inserted somewhere.
		((todo-result? resnode)
			(printinl indent "<dl>")
			(printinl indent "<dt>")
			(printinl indent "TODO: " (todo-result-message-ref resnode))
			(printinl indent "</dt>")
			;; dump out any warnings...
			(cond ((todo-result-warning? resnode)
				(printinl indent "<dt>")
				(printinl indent "<font color=#cccc66>")
				(printinl indent "WARNING: " 
					(todo-result-warning-ref resnode))
				(printinl indent "</font>")
				(printinl indent "</dt>")))
			(printinl indent "</dl>")
			(printinl indent "<br>"))

		;; print out any skipped thing the user may have done.
		((skip-result? resnode)
			(printinl indent "<dl>")
			(printinl indent "<dt>")
			(printinl indent "SKIP: " (skip-result-message-ref resnode))
			(printinl indent "</dt>")
			;; dump out any warnings...
			(cond ((skip-result-warning? resnode)
				(printinl indent "<dt>")
				(printinl indent "<font color=#cccc66>")
				(printinl indent "WARNING: " 
					(skip-result-warning-ref resnode))
				(printinl indent "</font>")
				(printinl indent "</dt>")))
			(printinl indent "</dl>"))

		(else
			(printinl indent "*** Error: Unknown result node!: " resnode))))))

	;; Generate the web page or die if bad arguments.
	(cond 
		((test-package-result? resnode)

			;; dump the prologue for the web page 
			(printnl "<html> <title> Testoutput </title>")
			(printnl "<body bgcolor=#000000 text=#3399ee link=#dddddd "
				"vlink=#888888>")

			;; Dump the header that says the entire thing failed or not.
			(if (equal? #t (test-package-result-result-ref resnode))
				(printnl "<h1> ALL TESTS PASSED! </h1>")
				(printnl "<h1> SOME TESTS FAILED! </h1>"))

			;; Dump the overall statistics

			;; Dump all of the packages

			;; Dump all of the cases

			;; Dump all of the expectations

			;; Dump the result tree
			(xlate 0 resnode)

			;; dump the epilogue for the web page 
			(printnl "</body> </html>")

			;; return the toplevel package result to the caller
			(test-package-result-result-ref resnode))

		(else
			(display "You did not pass (output-style-human ...) a valid ")
			(display "test package result tree.") 
			(newline))))))




