;;; File:
;;;   unit-test.ss
;;; Authors:
;;;   Janet L. N. Davis
;;;   Samuel A. Rebelsky
;;; Version:
;;;;  0.7 of 25 September 2006
;;; Summary:
;;;   A set of procedures that support a simple form of unit testing
;;;   for Scheme code.
;;; Contents:
;;;   (begin-tests!) - Set up the environment for testing
;;;   (test! expression value) - Determine whether (a) expression can
;;;     be evaluated and (b) the value of expression is value.
;;;   (test-error! expression) - Verify that expression is
;;;     erroneous (that is, that it cannot be evaluated).
;;;   (end-tests!) - Conclude a set of tests and report their results.
;;; Use:
;;;   In general, you begin a series of tests by calling (begin-tests!).
;;;   You conduct each test with the test! procedure, which takes two
;;;     parameters: (1) a list that represents an expression to be evaluated
;;;     (2) the expected value of that expression.
;;;   Use test-error! to evaluate expressions that should result in an error
;;;     (e.g., if a precondition is violated).
;;;   When you are done, you end the series of tests by calling (end-tests!).
;;;   This procedure will report on all the failures.
;;; Practica:
;;;   (begin-tests!)
;;;   (test! (reverse (list 'a 'b 'c)) (list 'c 'b 'a))
;;;   (test-error! (reverse 'spam))
;;;   (end-tests!)
;;; History:
;;;   At end.

; +---------------+--------------------------------------------------------
; | Encapsulation |
; +---------------+

;;; Procedure:
;;;   test-proc
;;; Parameters:
;;;   name, a symbol
;;; Purpose:
;;;   Given the name of a procedure, extracts its body.  
;;; Produces:
;;;   proc, a procedure
;;; Preconditions:
;;;   name must be 'begin-tests! 'test-kernel! 'test-error-kernel! or
;;;     'end-tests!
;;; Postconditions:
;;;   proc is a procedure that accomplishes the stated goals.  (See
;;;     below for those goals.)
;;; Philosophy:
;;;   This style of design permits us to encapsulate the variables shared
;;;   between procedures, and therefore makes the code a bit safer.
(define test-proc
  (let (
        ; A number that gives the count of tests performed.
        (tests 0)
        ; A list of errors encountered.  Each error has the form
        ;   (_expression_ _exception_)
        (errors null)
        ; A list of failed equality tests.  Each element has the form
        ;   (_expression_ _expected_value_ _actual_value_)
        (failures null))
    (letrec (
             ; (report-failures! remaining-failures)
             ;   Prints info about each of the failed tests.
             ;   Expects the form documented above.
             (report-failures!
              (lambda (remaining-failures)
                (if (not (null? remaining-failures))
                    (let ((error (car remaining-failures)))
                      (display "  For ")
                      (write (car error))
                      (display " expected [")
                      (write (cadr error))
                      (display "] got [")
                      (write (caddr error))
                      (display "]")
                      (newline)
                      (report-failures! (cdr remaining-failures))))))
             ; (report-errors! errors)
             ;   Prints a list of the errors encountered.  Assumes that 
             ;   the list has the form documented above.
             (report-errors!
              (lambda (remaining-errors)
                (if (not (null? remaining-errors))
                    (let ((exception (car remaining-errors)))
                      (display "  The expression ")
                      (display (car exception))
                      (display " failed to evaluate because [")
                      (display (exn-message  (cadr exception)))
                      (display "]")
                      (newline)
                      (report-errors! (cdr remaining-errors)))))))
    (lambda (proc)
      (cond 
        ((eq? proc 'begin-tests!)
         (lambda ()
           (set! failures null)
           (set! errors null)
           (set! tests 0)))
        ((eq? proc 'end-tests!)
         (lambda ()
           (let* ((num-errors (length errors))
                  (num-failures (length failures))
                  (total-failures (+ num-errors num-failures)))
             (display tests)
             (display " tests conducted.")
             (newline)
             (cond ((= total-failures 0) (display "No tests failed."))
                   ((= total-failures 1) (display "One test failed."))
                   (else (display total-failures) (display " tests failed.")))
             (newline)
             (cond ((= total-failures 0))
                   ((= num-errors 0)
                    (display "No errors encountered.") (newline))            
                   ((= num-errors 1) 
                    (display "One error encountered:") (newline))
                   (else 
                    (display num-errors) 
                    (display " errors encountered:") 
                    (newline)))
             (report-errors! (reverse errors))
             (cond ((= total-failures 0))
                   ((= num-failures 0)
                    (display "No other tests failed to give the expected result.") 
                    (newline))
                   ((= num-failures 1) 
                    (display "One other test failed to give the expected result:") 
                    (newline))
                   (else 
                    (display num-failures) 
                    (display " other tests failed to give the expected result:")
                    (newline)))
             (report-failures! (reverse failures))
             (if (= 0 (+ num-failures num-errors))
                 (display "CONGRATULATIONS!  All tests passed.")
                 (display "Sorry.  You'll need to fix your code."))
             (newline))))
        ((eq? proc 'test-kernel!)
         (lambda (exp expected) 
           (set! tests (+ tests 1))
           (with-handlers
               ((exn:fail?
                 (lambda (exception)
                   (set! errors
                         (cons (list exp exception) errors)))))
             (let ((result (eval exp)))
               (if (not (equal? result expected))
                   (set! failures 
                         (cons (list exp expected result) failures)))))))
        ((eq? proc 'test-error-kernel!)
         (lambda (exp) 
           (set! tests (+ tests 1))
           (with-handlers
               ((exn:fail?
                 (lambda (exception)
                   ; This is what we expected!  The next line is a hack for
                   ; "do nothing".
                   (set! exp exp))))
             (let ((result (eval exp)))
               ((set! failures (cons (list exp '<error> result) failures)))))))
        ((eq? proc 'test-permutation-kernel!)
         (lambda (exp lst)
           (set! tests (+ tests 1))
           (with-handlers
               ((exn:fail?
                 (lambda (exception)
                   (set! errors
                         (cons (list exp exception) errors)))))
             (let ((result (eval exp)))
               (if (not (ut-permutation? result lst))
                   (set! failures 
                         (cons (list exp (list 'permutation-of lst) result) failures)))))))
        (else (error "test-proc: unknown procedure")))))))


; +--------------------+---------------------------------------------------
; | Primary Procedures |
; +--------------------+

;;; Procedure:
;;;   begin-tests!
;;; Parameters:
;;;   (none)
;;; Purpose:
;;;   Prepare the system for testing.
;;; Produces:
;;;   Nothing.
;;; Preconditions:
;;;   (none)
;;; Postconditions:
;;;   The system is now in a state that permits use of the testing procedures.
(define begin-tests! (test-proc 'begin-tests!))

;;; Procedure:
;;;   test!
;;; Parameters:
;;;   exp, a Scheme value that represents an expression to be evaluated.
;;;   expected, a Scheme value that represents the expected result
;;; Purpose:
;;;   Evaluate exp and determine whether or not it equals expected.  In
;;;   either case, updates our testing statistics.
;;; Produces:
;;;   (nothing)
;;; Preconditions:
;;;   The test system has been initialized with begin-tests!
;;;   The test system has not been finished with end-tests!
;;; Postconditions:
;;;   The information in the test system has been updated appropriately.
(define-syntax test!
  (syntax-rules ()
    ((test! exp expected)
     (test-kernel! 'exp expected))))

(define test-kernel! (test-proc 'test-kernel!))

;;; Procedure:
;;;   test-error!
;;; Parameters:
;;;   exp, a Scheme value that represents an expression to be evaluated.
;;;   The expression should be one that is expected to generate an error.
;;; Purpose:
;;;   Evaluate exp and determine whether it generates an error.
;;;   If there is an error, the test succeeds.
;;;   Otherwise, the test fails.
;;;   In either case, updates our testing statistics.
;;; Produces:
;;;   (nothing)
;;; Preconditions:
;;;   The test system has been initialized with begin-tests!
;;;   The test system has not been finished with end-tests!
;;; Postconditions:
;;;   The information in the test system has been updated appropriately.
(define-syntax test-error!
  (syntax-rules ()
    ((test-error! exp)
     (test-error-kernel! 'exp))))

(define test-error-kernel! (test-proc 'test-error-kernel!))

;;; Procedure:
;;;   test-permutation!
;;; Parameters:
;;;   expression, an expression to test
;;;   lst, a list
;;; Purpose:
;;;   Evaluate expression and determine whether or not the result is a
;;;   permutation of lst.
;;; Produces:
;;;   (nothing)
;;; Preconditions:
;;;   (none)
;;; Postconditions:
;;;   The information in the test system has been updated appropriately.
(define-syntax test-permutation!
  (syntax-rules ()
    ((test-permutation! exp expected)
     (test-permutation-kernel! 'exp expected))))

(define test-permutation-kernel! (test-proc 'test-permutation-kernel!))

;;; Procedure:
;;;   end-tests!
;;; Parameters:
;;;   (none)
;;; Purpose:
;;;   Completes a sequence of tests.
;;; Produces:
;;;   (nothing) [displays results]
;;; Preconditions:
;;;   The test system has been initialized with begin-tests!
;;;   The test system has not been finished with end-tests!
;;; Postconditions:
;;;   Information about the tests has been displayed.
(define end-tests! (test-proc 'end-tests!))

; +-----------------+------------------------------------------------------
; | Local Utilities |
; +-----------------+

;;; Procedure:
;;;   ut-permutation?
;;; Parameters:
;;;   left, a list
;;;   right, a list
;;; Purpose:
;;;   Determines whether left is a permutation of right.
;;; Produces:
;;;   is-permutation?, a boolean
;;; Preconditions:
;;;   None
;;; Postconditions:
;;;   is-permutation? is true exactly when left and right are 
;;;   permutations of each other.
(define ut-permutation?
  (letrec
    ((member? (lambda (val lst)
                (and (not (null? lst))
                     (or (equal? val (car lst))
                         (member? val (cdr lst))))))
     (remove (lambda (val lst)
                (cond 
                  ((null? lst) null)
                  ((equal? val (car lst)) (cdr lst))
                  (else (cons (car lst) (remove val (cdr lst))))))))
    (lambda (left right)
      (or (and (null? left) (null? right))
          (and (not (null? left))
               (not (null? right))
               (member? (car left) right)
               (ut-permutation? (cdr left)
                                (remove (car left) right)))))))

; +---------+--------------------------------------------------------------
; | History |
; +---------+

; Friday, 22 September 2006 (v 0.1) [Janet L. N. Davis and Samuel A. Rebelsky]
; * Created.  Did not yet handle errors.

; Friday, 22 September 2006 (v 0.2) [Janet L. N. Davis and Samuel A. Rebelsky]
; * Added error handling code.
; * Added documentation.
; * Moved tests of the testing code to a separate file.
; * Renamed three core procedures.

; Friday, 22 September 2006 (v 0.3) [Janet L. N. Davis]
; * Added test-error! procedure.
; * Modified test! to use the exn:fail? procedure to test for an exception.
;   (This procedure is recommended as it does not catch the break exception.)
; * Fixed bug that caused report-failures-helper and report-errors-helper
;   to infinite-loop if there were multiple failures or errors.

; Friday, 22 September 2006 (v 0.4) [Samuel A. Rebelsky]
; * Replaced calls to "display" with calls to "write" for the expressions.
;   (Otherwise, the output is not quite so clear.)
; * Updated the final report for clarity (now reports total failures, errors,
;   and non-error failures).

; Sunday, 24 September 2006 (v 0.5) [Janet L. N. Davis]
; * Remembered to set errors to null in begin-tests!
; * Fixed bug in reporting the total number of errors.
; * Updated wording for test failures that are not unexpected errors.
; * Averted printing of superfluous newlines when all tests succeed.
; * Updated front matter.

; Sunday, 24 September 2006 (v 0.5.1) [Samuel A. Rebelsky]
; * Updated the message for tests that are not errors.
; * Updated the contents to give short definitions.

; Monday, 25 September 2006 (v 0.6) [Samuel A. Rebelsky]
; * Replaced test! and test-error! with macros (syntax definitions)
;   to simplify use.
; * Made test-error! return nothing (through a hack).

; Monday, 25 September 2006 (v 0.7) [Samuel A. Rebelsky]
; * Encapsulated global variables to reduce the chance of overlap with
;   client code.

; Monday, 2 October 2006 (v 0.8) [Samuel A. Rebelsky]
; * Added test-permutation!

; +-------+----------------------------------------------------------------
; | To Do |
; +-------+

; * Document helper procedures.
; * Continue to think about how to phrase the error/failure distinction.
; * Make the kernels local.
; * Add test-equals! test-true! test-false! (maybe)