plt/name-collector.ss
;;;
;;; Time-stamp: <05/10/07 13:48:31 nhw>
;;;
;;; 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 name-collector mzscheme

  (require "base.ss"
           "monad.ss"
           "hash-monad.ss"
           (lib "list.ss" "srfi" "1"))

  (provide display-test-case-name
           push-suite-name!
           pop-suite-name!
           put-initial-name)

  (define key (gensym))

  ;; put-initial-name : () -> (hash-monad-of void)
  (define (put-initial-name)
    (put key null))

  ;; display-test-case-name : test-result -> (hash-monad-of void)
  (define (display-test-case-name result)
    (compose
     (get key)
     (lambda (names)
       (cond
        ((test-success? result) (return-hash (void)))
        (else
         (newline)
         (fold-right
          (lambda (name seed)
            (printf "~a > " name))
          (void)
          names)
         (display (test-result-test-case-name result))
         (return-hash (void)))))))

  ;; push-suite-name! : string -> (hash-monad-of void)
  (define (push-suite-name! name)
    (compose
     (get key)
     (lambda (names)
       (put key (cons name names)))))

  ;; pop-suite-name! :  -> (hash-monad-of void)
  (define (pop-suite-name!)
    (compose
     (get key)
     (lambda (names)
       (put key (cdr names)))))

  )