text-ui.ss
;;!
;; A simple text interface for running tests and reporting results
(module text-ui mzscheme
  
    (require (lib "string.ss")
             (lib "match.ss")
             "schemeunit.ss"
             "assert-base.ss"
             "assert.ss"
             "assert-util.ss")

    (provide test/text-ui)

    (define-struct count (successes failures errors))
    (define (add-success! count)
      (set-count-successes! count (add1 (count-successes count))))
    (define (add-failure! count)
      (set-count-failures! count (add1 (count-failures count))))
    (define (add-error! count)
      (set-count-errors! count (add1 (count-errors count))))

    (define (print-success names result)
      (void))

    (define (print-common-info result)
      (let* ((stack (exn:test:assertion-stack result))
             (locrep (get-assertion-location-representative stack))
             (spacer (make-string 2 #\space)))
        (if locrep (printf "~a~n" (syntax->location-string locrep)))
        (let loop ((stack stack))
          (match stack
            (() 'done)
            ((first . rest)
             (if (eq? locrep first)
                 (loop rest)
                 (begin
                   (display spacer)
                   (printf "~a: ~s~n"
                           (assertion-info-name first)
                           (assertion-info-value first))
                   (loop rest))))))))

    (define (print-separator length)
      (printf "~a~n" (make-string length #\-)))

    (define (print-names names)
      (printf "~a" (car names))
      (for-each
       (lambda (name)
         (printf " < ~a" name))
       (cdr names))
      (newline))
    
    (define (print-failure names result)
      (newline)
      (print-names names)
      (printf "Has a FAILURE:~n")
      (print-common-info result)
      (newline))
        
    (define (print-error names result)
      (newline)
      (print-names names)
      (printf "Has an ERROR~n")
      (cond [(exn? result)
             (printf "  type: ~a~n" (object-name result))
             (printf "  message: ~e~n" (exn-message result))]
            [else
             (printf " an error occurred which was not an exception: ~e~n"
                     result)])
      (newline))

    (define print-summary
      (match-lambda
       [($ count successes failures errors)
        (printf "~a success(es)  ~a error(s)  ~a failure(s)~n"
                successes
                errors
                failures)]))
        
    ;; print-result : test-result (list-of string) -> void
    (define (print-result result names)
      (match result
        [($ test-failure case result)
         (print-failure names result)]
        [($ test-error case result)
         (print-error names result)]
        [($ test-success case result)
         (print-success names result)]))

    ;; update-count! : count test-result -> void
    (define (update-count! count result)
      (match result
        [($ test-failure case result)
         (add-failure! count)]
        [($ test-error case result)
         (add-error! count)]
        [($ test-success case result)
         (print-success case result)]))

    
    (define (test/text-ui test)
      ;; seed : (vector count (list-of string))
      (define seed
        (vector (make-count 0 0 0) null))
      (define (add-name seed name)
        (vector (get-count seed)
                (cons name (get-names seed))))
      (define (remove-name seed)
        (vector (get-count seed)
                (cdr (get-names seed))))
      (define (get-names seed)
        (vector-ref seed 1))
      (define (get-count seed)
        (vector-ref seed 0))
      (define (fdown name setup teardown seed)
        (setup)
        (add-name seed name))
      (define (fup name setup teardown seed kid-seed)
        (teardown)
        (remove-name kid-seed))
      (define (fhere name action setup teardown seed)
        (let ((result
               (run-test-case name action setup teardown)))
          (print-result result (cons name (get-names seed)))
          (update-count! (get-count seed) result) 
          seed))
      (print-summary
       (get-count (foldts fdown fup fhere seed test))))
    )