plt/text-ui.ss
;;;
;;; Time-stamp: <2007-02-16 20:34:37 noel>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;

;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.

;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE.  See the GNU Lesser General Public
;;; License for more details.

;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA

;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:

(module text-ui mzscheme

  (require (lib "include.ss")
           (lib "plt-match.ss")
           (only (lib "etc.ss") opt-lambda)
           (lib "string.ss" "srfi" "13")
           "location.ss"
           "test.ss"
           "monad.ss"
           "hash-monad.ss"
           "counter.ss"
           "name-collector.ss"
           "text-ui-util.ss")

  (provide test/text-ui
           display-check-info
           display-exn
           display-summary+return
           display-ticker
           display-result)

  (include "../generic/text-ui.ss")

  ;; display-exn : exn -> void
  ;;
  ;; Outputs a printed representation of the exception to
  ;; the current-output-port
  (define (display-exn exn)
    (let ([op (open-output-string)])
      (parameterize ([current-error-port op])
        ((error-display-handler)
         (exn-message exn)
         exn))
      (display (get-output-string op))
      (newline)))

  ;; display-check-info : test-result -> void
  (define (display-check-info result)
    (cond
     ((test-failure? result)
      (let* ((exn (test-failure-result result))
             (stack (exn:test:check-stack exn)))
        (for-each
         (lambda (info)
           (let ((value (check-info-value info)))
             (cond
              ((check-name? info)
               (printf "name: ~a\n" value))
              ((check-location? info)
               (printf "location: ~a\n"
                       (trim-current-directory
                        (location->string
                         (check-info-value info)))))
              ((check-params? info)
               (unless (null? value)
                 (printf "params: ~v\n" value)))
              ((check-expression? info))
              (else
               (printf "~a: ~v\n"
                       (check-info-name info)
                       value)))))

         stack)))
     ((test-error? result)
      (display-exn (test-error-result result)))
     (else
      (void))))

  ;; display-verbose-check-info : test-result -> void
  (define (display-verbose-check-info result)
    (cond
     ((test-failure? result)
      (let* ((exn (test-failure-result result))
             (stack (exn:test:check-stack exn)))
        (for-each
         (lambda (info)
           (cond
            ((check-location? info)
             (display "location: ")
             (display (trim-current-directory
                       (location->string
                        (check-info-value info)))))
            (else
             (display (check-info-name info))
             (display ": ")
             (write (check-info-value info))))
           (newline))
         stack)))
     ((test-error? result)
      (display-exn (test-error-result result)))
     (else
      (void))))

  (define (std-test/text-ui display-check-info test)
    (fold-test-results
     (lambda (result seed)
       ((sequence* (update-counter! result)
                   (display-test-case-name result)
                   (lambda (hash)
                     (display-result result)
                     (display-check-info result)
                     hash))
        seed))
     ((sequence
        (put-initial-counter)
        (put-initial-name))
      (make-empty-hash))
     test
     #:fdown (lambda (name seed) ((push-suite-name! name) seed))
     #:fup (lambda (name kid-seed) ((pop-suite-name!) kid-seed))))

  (define (display-summary+return monad)
    (monad-value
       ((compose
         (sequence*
          (display-counter)
          (counter->vector))
         (match-lambda
          ((vector s f e)
           (return-hash (+ f e)))))
        monad)))
  
  ;; test/text-ui : test [(U 'quiet 'normal 'verbose)] -> integer
  (define test/text-ui
    (opt-lambda (test [mode 'normal])
      (monad-value
       ((compose
         (sequence*
          (display-counter)
          (counter->vector))
         (match-lambda
          ((vector s f e)
           (return-hash (+ f e)))))
        (case mode
          ((quiet)
           (fold-test-results
            (lambda (result seed)
              ((update-counter! result) seed))
            ((put-initial-counter)
             (make-empty-hash))
            test))
          ((normal) (std-test/text-ui display-check-info test))
          ((verbose) (std-test/text-ui display-verbose-check-info test)))))))
  )