254 lines
6.9 KiB
Scheme
254 lines
6.9 KiB
Scheme
;;;
|
|
;;; Time-stamp: <2009-06-11 17:11:22 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:
|
|
|
|
#lang scheme/base
|
|
|
|
(require scheme/match
|
|
scheme/pretty
|
|
srfi/13
|
|
srfi/26)
|
|
|
|
(require "base.ss"
|
|
"counter.ss"
|
|
"format.ss"
|
|
"location.ss"
|
|
"result.ss"
|
|
"test.ss"
|
|
"check-info.ss"
|
|
"monad.ss"
|
|
"hash-monad.ss"
|
|
"name-collector.ss"
|
|
"text-ui-util.ss")
|
|
|
|
(provide run-tests
|
|
display-context
|
|
display-exn
|
|
display-summary+return
|
|
display-ticker
|
|
display-result)
|
|
|
|
|
|
;; display-ticker : test-result -> void
|
|
;;
|
|
;; Prints a summary of the test result
|
|
(define (display-ticker result)
|
|
(cond
|
|
((test-error? result)
|
|
(display "!"))
|
|
((test-failure? result)
|
|
(display "-"))
|
|
(else
|
|
(display "."))))
|
|
|
|
;; display-test-preamble : test-result -> (hash-monad-of void)
|
|
(define (display-test-preamble result)
|
|
(lambda (hash)
|
|
(if (test-success? result)
|
|
hash
|
|
(begin
|
|
(display-delimiter)
|
|
hash))))
|
|
|
|
;; display-test-postamble : test-result -> (hash-monad-of void)
|
|
(define (display-test-postamble result)
|
|
(lambda (hash)
|
|
(if (test-success? result)
|
|
hash
|
|
(begin
|
|
(display-delimiter)
|
|
hash))))
|
|
|
|
|
|
;; display-result : test-result -> void
|
|
(define (display-result result)
|
|
(cond
|
|
((test-error? result)
|
|
(display-test-name (test-result-test-case-name result))
|
|
(display-error)
|
|
(newline))
|
|
((test-failure? result)
|
|
(display-test-name (test-result-test-case-name result))
|
|
(display-failure)
|
|
(newline))
|
|
(else
|
|
(void))))
|
|
|
|
|
|
;; strip-redundant-parms : (list-of check-info) -> (list-of check-info)
|
|
;;
|
|
;; Strip any check-params? is there is an
|
|
;; actual/expected check-info in the same stack frame. A
|
|
;; stack frame is delimited by occurrence of a check-name?
|
|
(define (strip-redundant-params stack)
|
|
(define (binary-check-this-frame? stack)
|
|
(let loop ([stack stack])
|
|
(cond
|
|
[(null? stack) #f]
|
|
[(check-name? (car stack)) #f]
|
|
[(check-actual? (car stack)) #t]
|
|
[else (loop (cdr stack))])))
|
|
(let loop ([stack stack])
|
|
(cond
|
|
[(null? stack) null]
|
|
[(check-params? (car stack))
|
|
(if (binary-check-this-frame? stack)
|
|
(loop (cdr stack))
|
|
(cons (car stack) (loop (cdr stack))))]
|
|
[else (cons (car stack) (loop (cdr stack)))])))
|
|
|
|
|
|
;; display-context : test-result [(U #t #f)] -> void
|
|
(define (display-context result [verbose? #f])
|
|
(cond
|
|
[(test-failure? result)
|
|
(let* ([exn (test-failure-result result)]
|
|
[stack (exn:test:check-stack exn)])
|
|
(textui-display-check-info-stack stack verbose?))]
|
|
[(test-error? result)
|
|
(let ([exn (test-error-result result)])
|
|
(textui-display-check-info-stack (check-info-stack (exn-continuation-marks exn)))
|
|
(display-exn exn))]
|
|
[else (void)]))
|
|
|
|
(define (textui-display-check-info-stack stack [verbose? #f])
|
|
(for-each
|
|
(lambda (info)
|
|
(cond
|
|
[(check-name? info)
|
|
(display-check-info info)]
|
|
[(check-location? info)
|
|
(display-check-info-name-value
|
|
'location
|
|
(trim-current-directory
|
|
(location->string
|
|
(check-info-value info)))
|
|
display)]
|
|
[(check-params? info)
|
|
(display-check-info-name-value
|
|
'params
|
|
(check-info-value info)
|
|
(lambda (v) (map pretty-print v)))]
|
|
[(check-actual? info)
|
|
(display-check-info-name-value
|
|
'actual
|
|
(check-info-value info)
|
|
pretty-print)]
|
|
[(check-expected? info)
|
|
(display-check-info-name-value
|
|
'expected
|
|
(check-info-value info)
|
|
pretty-print)]
|
|
[(and (check-expression? info)
|
|
(not verbose?))
|
|
(void)]
|
|
[else
|
|
(display-check-info info)]))
|
|
(if verbose?
|
|
stack
|
|
(strip-redundant-params stack))))
|
|
|
|
;; 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-context test)
|
|
(begin0 (fold-test-results
|
|
(lambda (result seed)
|
|
((sequence* (update-counter! result)
|
|
(display-test-preamble result)
|
|
(display-test-case-name result)
|
|
(lambda (hash)
|
|
(display-result result)
|
|
(display-context result)
|
|
hash)
|
|
(display-test-postamble result))
|
|
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)))
|
|
|
|
;; run-tests : test [(U 'quiet 'normal 'verbose)] -> integer
|
|
(define (run-tests 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-context test))
|
|
((verbose) (std-test/text-ui
|
|
(cut display-context <> #t)
|
|
test))))))
|
|
|