suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Decouple depnendce on mred

Browse Source 
svn: r9208
This commit is contained in:
Kathy Gray 2008-04-08 21:30:38 +00:00
parent 1f72a6db65
commit cec232b83f
3 changed files with 100 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/test-engine/scheme-tests.ss
View File

@ -6,8 +6,7 @@
mzlib/pretty
mzlib/pconvert
mzlib/class
"scheme-gui.scm"
"test-display.scm")
"scheme-gui.scm")
(require-for-syntax stepper/private/shared)
@ -48,6 +47,8 @@
(current-namespace))])
(and test-info
(let ([display-data (scheme-test-data)])
(send test-info refine-display-class
(dynamic-require '(lib "test-display.scm" "test-engine") 'test-display%))
(send test-info setup-display
(car display-data) (cadr display-data))
(send test-info summarize-results (current-output-port)))))
@ -60,7 +61,6 @@
#'(let ([test-info (namespace-variable-value 'test~object #f builder
(current-namespace))])
(and test-info
(send test-info refine-display-class test-display-textual%)
(send test-info summarize-results (current-output-port))))
'test-call #t)]))

95
collects/test-engine/test-display.scm
View File

@ -282,97 +282,4 @@
(list (send parent get-percentages)))
(send parent delete-child this)))))
(define test-display-textual%
(class* object% ()
(init-field (current-rep #f))
(define test-info #f)
(define/pubment (install-info t)
(set! test-info t)
(inner (void) install-info t))
(define/public (display-results)
(send this insert-test-results test-info))
(define/pubment (insert-test-results test-info)
(let* ([style (send test-info test-style)]
[total-tests (send test-info tests-run)]
[failed-tests (send test-info tests-failed)]
[total-checks (send test-info checks-run)]
[failed-checks (send test-info checks-failed)]
[test-outcomes
(lambda (zero-message)
(printf "~a"
(cond [(zero? total-tests) zero-message]
[(= 1 total-tests) "Ran 1 test.\n"]
[else (format "Ran ~a tests.\n" total-tests)]))
(when (> total-tests 0)
(printf "~a"
(cond
[(and (zero? failed-tests) (= 1 total-tests))
"Test passed!\n\n"]
[(zero? failed-tests) "All tests passed!\n\n"]
[(= failed-tests total-tests) "0 tests passed.\n"]
[else "~a of the ~a tests failed.\n\n"]))))]
[check-outcomes
(lambda (zero-message)
(printf "~a"
(cond
[(zero? total-checks) zero-message]
[(= 1 total-checks) "Ran 1 check.\n"]
[else (format "Ran ~a checks.\n" total-checks)]))
(when (> total-checks 0)
(printf "~a"
(cond
[(and (zero? failed-checks) (= 1 total-checks))
"Check passed!\n\n"]
[(zero? failed-checks) "All checks passed!\n\n"]
[(= failed-checks total-checks) "0 checks passed.\n"]
[else (format "~a of the ~a checks failed.\n\n"
failed-checks total-checks)]))))])
(case style
[(test-require)
(test-outcomes "This program must be tested!\n")
(check-outcomes "This program is unchecked!\n")]
[(check-require)
(check-outcomes "This program is unchecked!\n")]
[(test-basic)
(test-outcomes "")
(check-outcomes "")]
[else (check-outcomes "")])
(unless (and (zero? total-checks) (zero? total-tests))
(inner (display-check-failures (send test-info failed-checks)
test-info)
insert-test-results test-info))))
(define/public (display-check-failures checks test-info)
(for ([failed-check (reverse checks)])
(printf "~a" "\t")
(make-link (failed-check-msg failed-check)
(failed-check-src failed-check))
(printf "~a" "\n")))
(define/public (next-line) (printf "~a" "\n\t"))
;; make-link: (listof (U string snip%)) src -> void
(define (make-link msg dest)
(for-each printf msg)
(printf (format-src dest)))
(define (format-src src)
(let ([src-file car]
[src-line cadr]
[src-col caddr])
(string-append
(cond [(symbol? (src-file src)) " At "]
[(path? (src-file src))
(string-append " In " (path->string (src-file src)) " at ")]
[(is-a? (src-file src) editor<%>) " At "])
"line " (number->string (src-line src))
" column " (number->string (src-col src)))))
(super-instantiate ())))
(provide test-panel% test-window% test-display% test-display-textual%)
(provide test-panel% test-window% test-display%)

100
collects/test-engine/test-engine.scm
View File

@ -1,15 +1,107 @@
#lang scheme/base
(require scheme/class
"test-info.scm"
"test-display.scm")
"test-info.scm")
(define test-display-textual%
(class* object% ()
(init-field (current-rep #f))
(define test-info #f)
(define/pubment (install-info t)
(set! test-info t)
(inner (void) install-info t))
(define/public (display-results)
(send this insert-test-results test-info))
(define/pubment (insert-test-results test-info)
(let* ([style (send test-info test-style)]
[total-tests (send test-info tests-run)]
[failed-tests (send test-info tests-failed)]
[total-checks (send test-info checks-run)]
[failed-checks (send test-info checks-failed)]
[test-outcomes
(lambda (zero-message)
(printf "~a"
(cond [(zero? total-tests) zero-message]
[(= 1 total-tests) "Ran 1 test.\n"]
[else (format "Ran ~a tests.\n" total-tests)]))
(when (> total-tests 0)
(printf "~a"
(cond
[(and (zero? failed-tests) (= 1 total-tests))
"Test passed!\n\n"]
[(zero? failed-tests) "All tests passed!\n\n"]
[(= failed-tests total-tests) "0 tests passed.\n"]
[else "~a of the ~a tests failed.\n\n"]))))]
[check-outcomes
(lambda (zero-message)
(printf "~a"
(cond
[(zero? total-checks) zero-message]
[(= 1 total-checks) "Ran 1 check.\n"]
[else (format "Ran ~a checks.\n" total-checks)]))
(when (> total-checks 0)
(printf "~a"
(cond
[(and (zero? failed-checks) (= 1 total-checks))
"Check passed!\n\n"]
[(zero? failed-checks) "All checks passed!\n\n"]
[(= failed-checks total-checks) "0 checks passed.\n"]
[else (format "~a of the ~a checks failed.\n\n"
failed-checks total-checks)]))))])
(case style
[(test-require)
(test-outcomes "This program must be tested!\n")
(check-outcomes "This program is unchecked!\n")]
[(check-require)
(check-outcomes "This program is unchecked!\n")]
[(test-basic)
(test-outcomes "")
(check-outcomes "")]
[else (check-outcomes "")])
(unless (and (zero? total-checks) (zero? total-tests))
(inner (display-check-failures (send test-info failed-checks)
test-info)
insert-test-results test-info))))
(define/public (display-check-failures checks test-info)
(for ([failed-check (reverse checks)])
(printf "~a" "\t")
(make-link (failed-check-msg failed-check)
(failed-check-src failed-check))
(printf "~a" "\n")))
(define/public (next-line) (printf "~a" "\n\t"))
;; make-link: (listof (U string snip%)) src -> void
(define (make-link msg dest)
(for-each printf msg)
(printf (format-src dest)))
(define (format-src src)
(let ([src-file car]
[src-line cadr]
[src-col caddr])
(string-append
(cond [(symbol? (src-file src)) " At "]
[(path? (src-file src))
(string-append " In " (path->string (src-file src)) " at ")]
[else " At "])
"line " (number->string (src-line src))
" column " (number->string (src-col src)))))
(super-instantiate ())))
(define test-engine%
(class* object% ()
(field [test-info #f]
[test-display #f])
(define display-class test-display%)
(define display-class test-display-textual%)
(define display-rep #f)
(define display-event-space #f)
@ -62,4 +154,4 @@
(define/pubment (run-testcase testcase)
(inner (void) run-testcase testcase))))
(provide test-engine%)
(provide test-engine% test-display-textual%)