;;;
;;; Time-stamp: <06/03/11 12:19:25 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")
           (planet "aif.ss" ("schematics" "macro.plt"))
           "location.ss"
           "test.ss"
           "monad.ss"
           "hash-monad.ss"
           "counter.ss"
           "name-collector.ss")

  (provide test/text-ui)

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

  (define (display-exn exn)
    (display (exn-message exn))
    (newline))

  ;; trim-current-directory : string -> string
  (define (trim-current-directory path)
    (let ((cd (path->string (current-directory))))
      (aif index (string-contains path cd)
           (string-drop path (add1 (string-length cd)))
           path)))

  ;; 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)
    (foldts (lambda (suite name before after seed)
              ((push-suite-name! name) seed))
            (lambda (suite name before after seed kid-seed)
              ((pop-suite-name!) kid-seed))
            (lambda (case name action seed)
              (let ((result (run-test-case name action)))
                ((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))

  ;; 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 (name seed) seed)
            (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)))))))
  )