Repairing SchemeUnit tests re: DrDr
svn: r18673
This commit is contained in:
Jay McCarthy
parent
0b33e15553
commit
0289edf0cb
|
|
@ -57,12 +57,12 @@
|
|||
;; Prints a summary of the test result
|
||||
(define (display-ticker result)
|
||||
(cond
|
||||
((test-error? result)
|
||||
(display "!"))
|
||||
((test-failure? result)
|
||||
(display "-"))
|
||||
(else
|
||||
(display "."))))
|
||||
((test-error? result)
|
||||
(display "!"))
|
||||
((test-failure? result)
|
||||
(display "-"))
|
||||
(else
|
||||
(display "."))))
|
||||
|
||||
;; display-test-preamble : test-result -> (hash-monad-of void)
|
||||
(define (display-test-preamble result)
|
||||
|
|
@ -72,7 +72,7 @@
|
|||
(begin
|
||||
(display-delimiter)
|
||||
hash))))
|
||||
|
||||
|
||||
;; display-test-postamble : test-result -> (hash-monad-of void)
|
||||
(define (display-test-postamble result)
|
||||
(lambda (hash)
|
||||
|
|
@ -86,16 +86,16 @@
|
|||
;; 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))))
|
||||
((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)
|
||||
|
|
@ -107,66 +107,66 @@
|
|||
(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))])))
|
||||
[(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)))])))
|
||||
|
||||
|
||||
[(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)]))
|
||||
[(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)]))
|
||||
[(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))))
|
||||
|
|
@ -174,27 +174,27 @@
|
|||
;; 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))))
|
||||
((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)
|
||||
(parameterize ([current-output-port (current-error-port)])
|
||||
|
|
@ -221,23 +221,37 @@
|
|||
(monad-value
|
||||
((compose
|
||||
(sequence*
|
||||
(display-counter)
|
||||
(display-counter*)
|
||||
(counter->vector))
|
||||
(match-lambda
|
||||
((vector s f e)
|
||||
(return-hash (+ f e)))))
|
||||
((vector s f e)
|
||||
(return-hash (+ f e)))))
|
||||
monad)))
|
||||
|
||||
|
||||
(define (display-counter*)
|
||||
(compose (counter->vector)
|
||||
(match-lambda
|
||||
[(vector s f e)
|
||||
(if (and (zero? f) (zero? e))
|
||||
(display-counter)
|
||||
(lambda args
|
||||
(parameterize ([current-output-port (current-error-port)])
|
||||
(apply (display-counter) args))))])))
|
||||
|
||||
;; run-tests : test [(U 'quiet 'normal 'verbose)] -> integer
|
||||
(define (run-tests test [mode 'normal])
|
||||
(monad-value
|
||||
((compose
|
||||
(sequence*
|
||||
(display-counter)
|
||||
(case mode
|
||||
[(normal verbose)
|
||||
(display-counter*)]
|
||||
[(quiet)
|
||||
(lambda (a) a)])
|
||||
(counter->vector))
|
||||
(match-lambda
|
||||
((vector s f e)
|
||||
(return-hash (+ f e)))))
|
||||
((vector s f e)
|
||||
(return-hash (+ f e)))))
|
||||
(case mode
|
||||
((quiet)
|
||||
(fold-test-results
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@
|
|||
"text-ui-util-test.ss")
|
||||
|
||||
(provide all-schemeunit-tests
|
||||
success-and-failure-tests)
|
||||
failure-tests)
|
||||
|
||||
(define all-schemeunit-tests
|
||||
(test-suite
|
||||
|
|
@ -41,11 +41,9 @@
|
|||
format-tests
|
||||
))
|
||||
|
||||
;; These tests fail. The are intended to do this so a human can manually check the output they produce. They should not be run by DrDr as they will generate bogus warnings.
|
||||
(define success-and-failure-tests
|
||||
(define failure-tests
|
||||
(test-suite
|
||||
"Successes and Failures"
|
||||
all-schemeunit-tests
|
||||
"Failures"
|
||||
(test-case "Intended to fail" (fail))
|
||||
(test-case "Also intended to fail" (check-eq? 'apples 'orange))
|
||||
(test-equal? "Yet again intended to fail" "apples" "oranges")
|
||||
|
|
|
|||
|
|
@ -6,5 +6,7 @@
|
|||
|
||||
(run-tests all-schemeunit-tests)
|
||||
|
||||
;; Don't run the failing tests by default. Switch the comments if you want to inspect the visual appearance of failing test's output.
|
||||
;(run-tests success-and-failure-tests)
|
||||
;; These tests should all error, so we switch the meaning of correct and incorrect. If the error display changes significantly, DrDr will catch it
|
||||
(parameterize ([current-error-port (current-output-port)]
|
||||
[current-output-port (current-error-port)])
|
||||
(run-tests failure-tests))
|
||||
|
|
|
|||
|
|
@ -29,6 +29,8 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/runtime-path
|
||||
scheme/pretty
|
||||
scheme/port
|
||||
srfi/1
|
||||
srfi/13
|
||||
schemeunit
|
||||
|
|
@ -36,35 +38,22 @@
|
|||
|
||||
(provide text-ui-tests)
|
||||
|
||||
(define-syntax-rule (with-all-output-to-string e ...)
|
||||
(with-all-output-to-string* (lambda () e ...)))
|
||||
|
||||
;; Reimplement with-output-to-string to avoid dependency on
|
||||
;; io.plt, which in turn depends on SchemeUnit 1.2, which
|
||||
;; has not been ported to PLT 4.
|
||||
(define-syntax with-output-to-string
|
||||
(syntax-rules ()
|
||||
[(with-output-to-string expr ...)
|
||||
(let ([p (open-output-string)])
|
||||
(parameterize ([current-output-port p])
|
||||
expr ...)
|
||||
(get-output-string p))]))
|
||||
|
||||
(define-syntax with-error-to-string
|
||||
(syntax-rules ()
|
||||
[(with-error-to-string expr ...)
|
||||
(let ([p (open-output-string)])
|
||||
(parameterize ([current-error-port p])
|
||||
expr ...)
|
||||
(get-output-string p))]))
|
||||
(define (with-all-output-to-string* thnk)
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(parameterize ([current-error-port (current-output-port)])
|
||||
(thnk)))))
|
||||
|
||||
(define-runtime-path here ".")
|
||||
|
||||
;; with-silent-output (() -> any) -> any
|
||||
(define (with-silent-output thunk)
|
||||
(let ([out (open-output-string)]
|
||||
[err (open-output-string)])
|
||||
(parameterize ([current-output-port out]
|
||||
[current-error-port err])
|
||||
(thunk))))
|
||||
(parameterize ([current-output-port (open-output-nowhere)]
|
||||
[current-error-port (open-output-nowhere)])
|
||||
(thunk)))
|
||||
|
||||
(define (failing-test)
|
||||
(run-tests
|
||||
|
|
@ -109,7 +98,7 @@
|
|||
|
||||
(test-case
|
||||
"Binary check displays actual and expected in failure error message"
|
||||
(let ((op (with-error-to-string (failing-test))))
|
||||
(let ((op (with-all-output-to-string (failing-test))))
|
||||
(check string-contains
|
||||
op
|
||||
"expected")
|
||||
|
|
@ -119,14 +108,15 @@
|
|||
|
||||
(test-case
|
||||
"Binary check doesn't display params"
|
||||
(let ((op (with-error-to-string (failing-test))))
|
||||
(let ((op (with-all-output-to-string (failing-test))))
|
||||
(check (lambda (out str) (not (string-contains out str)))
|
||||
op
|
||||
"params")))
|
||||
|
||||
(test-case
|
||||
"Binary check output is pretty printed"
|
||||
(let ([op (with-error-to-string (failing-binary-test/complex-params))])
|
||||
(let ([op (parameterize ([pretty-print-columns 80])
|
||||
(with-all-output-to-string (failing-binary-test/complex-params)))])
|
||||
(check string-contains
|
||||
op
|
||||
"((0 1 2 3 4 5 6 7 8 9 10 11 12 13 14)
|
||||
|
|
@ -135,7 +125,8 @@
|
|||
|
||||
(test-case
|
||||
"Non-binary check output is pretty printed"
|
||||
(let ([op (with-error-to-string (failing-test/complex-params))])
|
||||
(let ([op (parameterize ([pretty-print-columns 80])
|
||||
(with-all-output-to-string (failing-test/complex-params)))])
|
||||
(check string-contains
|
||||
op
|
||||
"((0 1 2 3 4 5 6 7 8 9 10 11 12 13 14)
|
||||
|
|
@ -145,14 +136,14 @@
|
|||
(test-case
|
||||
"Location trimmed when file is under current directory"
|
||||
(parameterize ((current-directory here))
|
||||
(let ((op (with-error-to-string (failing-test))))
|
||||
(let ((op (with-all-output-to-string (failing-test))))
|
||||
(check string-contains
|
||||
op
|
||||
"location: text-ui-test.ss"))))
|
||||
|
||||
(test-case
|
||||
"Name and location displayed before actual/expected"
|
||||
(let ((op (with-error-to-string (failing-test))))
|
||||
(let ((op (with-all-output-to-string (failing-test))))
|
||||
(let ((name-idx (string-contains op "name:"))
|
||||
(loc-idx (string-contains op "location:"))
|
||||
(actual-idx (string-contains op "actual:"))
|
||||
|
|
@ -163,65 +154,71 @@
|
|||
|
||||
(test-case
|
||||
"Quiet mode is quiet"
|
||||
(let ((op1 (with-error-to-string (quiet-failing-test)))
|
||||
(op2 (with-error-to-string (quiet-error-test))))
|
||||
(let ((op1 (with-all-output-to-string (quiet-failing-test)))
|
||||
(op2 (with-all-output-to-string (quiet-error-test))))
|
||||
(check string=? op1 "")
|
||||
(check string=? op2 "")))
|
||||
|
||||
|
||||
(test-case
|
||||
"Number of unsuccessful tests returned"
|
||||
(check-equal? (with-silent-output failing-test) 1)
|
||||
(check-equal? (with-silent-output quiet-failing-test) 1)
|
||||
(check-equal? (with-silent-output quiet-error-test) 1)
|
||||
(check-equal? (with-silent-output
|
||||
(lambda ()
|
||||
(run-tests
|
||||
(test-suite
|
||||
"Dummy"
|
||||
(test-case "Dummy" (check-equal? 1 1)))
|
||||
'quiet)))
|
||||
(lambda ()
|
||||
(run-tests
|
||||
(test-suite
|
||||
"Dummy"
|
||||
(test-case "Dummy" (check-equal? 1 1)))
|
||||
'quiet)))
|
||||
0))
|
||||
|
||||
(test-case
|
||||
"run-tests runs suite before/after actions in quiet mode"
|
||||
(let ([foo 1])
|
||||
(run-tests
|
||||
(test-suite
|
||||
"Foo"
|
||||
#:before (lambda () (set! foo 2))
|
||||
#:after (lambda () (set! foo 3))
|
||||
(test-case
|
||||
"Foo check"
|
||||
(check = foo 2)))
|
||||
'quiet)
|
||||
(check = foo 3)))
|
||||
(with-silent-output
|
||||
(λ ()
|
||||
(let ([foo 1])
|
||||
(run-tests
|
||||
(test-suite
|
||||
"Foo"
|
||||
#:before (lambda () (set! foo 2))
|
||||
#:after (lambda () (set! foo 3))
|
||||
(test-case
|
||||
"Foo check"
|
||||
(check = foo 2)))
|
||||
'quiet)
|
||||
(check = foo 3)))))
|
||||
|
||||
(test-case
|
||||
"run-tests runs suite before/after actions in normal mode"
|
||||
(let ([foo 1])
|
||||
(run-tests
|
||||
(test-suite
|
||||
"Foo"
|
||||
#:before (lambda () (set! foo 2))
|
||||
#:after (lambda () (set! foo 3))
|
||||
(test-case
|
||||
"Foo check"
|
||||
(check = foo 2)))
|
||||
'normal)
|
||||
(check = foo 3)))
|
||||
(with-silent-output
|
||||
(λ ()
|
||||
(let ([foo 1])
|
||||
(run-tests
|
||||
(test-suite
|
||||
"Foo"
|
||||
#:before (lambda () (set! foo 2))
|
||||
#:after (lambda () (set! foo 3))
|
||||
(test-case
|
||||
"Foo check"
|
||||
(check = foo 2)))
|
||||
'normal)
|
||||
(check = foo 3)))))
|
||||
|
||||
(test-case
|
||||
"run-tests runs suite before/after actions in verbose mode"
|
||||
(let ([foo 1])
|
||||
(run-tests
|
||||
(test-suite
|
||||
"Foo"
|
||||
#:before (lambda () (set! foo 2))
|
||||
#:after (lambda () (set! foo 3))
|
||||
(test-case
|
||||
"Foo check"
|
||||
(check = foo 2)))
|
||||
'verbose)
|
||||
(check = foo 3)))
|
||||
(with-silent-output
|
||||
(λ ()
|
||||
(let ([foo 1])
|
||||
(run-tests
|
||||
(test-suite
|
||||
"Foo"
|
||||
#:before (lambda () (set! foo 2))
|
||||
#:after (lambda () (set! foo 3))
|
||||
(test-case
|
||||
"Foo check"
|
||||
(check = foo 2)))
|
||||
'verbose)
|
||||
(check = foo 3)))))
|
||||
))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user