376 lines
14 KiB
Scheme
376 lines
14 KiB
Scheme
#lang scheme/base
|
|
|
|
(require scheme/class
|
|
mzlib/etc
|
|
profj/display-java
|
|
"test-engine.scm"
|
|
"test-display.scm"
|
|
"test-info.scm"
|
|
"test-coverage.scm")
|
|
|
|
(define (java-test-maker test-info-class style)
|
|
(class* test-engine% ()
|
|
|
|
(inherit initialize-test run-test)
|
|
(inherit-field test-info test-display)
|
|
|
|
(super-instantiate ())
|
|
|
|
(field [tests null]
|
|
[test-objs null])
|
|
|
|
(define/override (info-class) test-info-class)
|
|
|
|
(define/public (install-tests tsts) (set! tests tsts))
|
|
(define/public (get-info)
|
|
(unless test-info (send this setup-info style))
|
|
test-info)
|
|
|
|
(define/public (test-objects) test-objs)
|
|
|
|
(define/augment (run)
|
|
(for ([t tests]) (initialize-test t))
|
|
(inner (void) run)
|
|
(for ([t tests]) (run-test t)))))
|
|
|
|
(define (java-test test-info-class)
|
|
(class* (java-test-maker test-info-class 'test-basic) ()
|
|
|
|
(super-instantiate ())
|
|
(inherit-field test-info test-objs)
|
|
|
|
(define/augride (run-test test)
|
|
(let ([test-name (car test)]
|
|
[test-class (cadr test)]
|
|
[test-src (caddr test)])
|
|
;; need to run constructor
|
|
(send test-info add-test-class test-name test-src)
|
|
(let ([test-obj (make-object test-class)])
|
|
(set! test-objs (cons test-obj test-objs))
|
|
(for ([tc (send test-obj testMethods)]) (run-testcase tc))
|
|
(let ([tested-classes (send test-obj testedClasses)])
|
|
(send test-info add-tests-info tested-classes
|
|
(map (lambda (c) (send test-obj testedMethods c))
|
|
tested-classes)
|
|
(map (lambda (c) (send test-obj testedMethodsSrcs c))
|
|
tested-classes))))
|
|
(send test-info complete-test)))
|
|
|
|
(define/augride (run-testcase tc)
|
|
(send test-info add-testcase (car tc) (car tc))
|
|
;; put this in a with-handlers
|
|
(let ([res ((cadr tc))]) (send test-info complete-testcase res)))))
|
|
|
|
(define (java-examples test-info-class)
|
|
(class* (java-test-maker test-info-class 'test-basic) ()
|
|
(super-instantiate ())
|
|
|
|
(inherit-field test-info test-objs)
|
|
|
|
(define/augride (run-test test)
|
|
(let ([test-name (car test)]
|
|
[test-class (cadr test)]
|
|
[test-src (caddr test)])
|
|
(send test-info add-test-class test-name test-src)
|
|
(send test-info add-inits test-name test-src)
|
|
(let ([test-obj (make-object test-class)])
|
|
(send test-info complete-testcase #t)
|
|
(set! test-objs (cons test-obj test-objs))
|
|
(with-handlers ((exn? (lambda (e) (raise e))))
|
|
((current-eval)
|
|
#`(send #,test-obj
|
|
#,(string->symbol (string-append test-name
|
|
"-constructor")))))
|
|
(for ([tc (build-testcases test-obj)]) (run-testcase tc))
|
|
(send test-info complete-test))))
|
|
|
|
(define/private (build-testcases object)
|
|
(let ([methods (reverse (interface->method-names
|
|
(object-interface object)))])
|
|
(map (lambda (m)
|
|
(list m (lambda () ((current-eval) #`(send #,object #,m))) #f))
|
|
methods)))
|
|
|
|
(define/augride (run-testcase tc)
|
|
(cond [(test-method? (car tc))
|
|
(send test-info add-testcase (car tc) (car tc))
|
|
(let ([res ((cadr tc))])
|
|
(send test-info complete-testcase res))] ; insert with-handlers
|
|
[(test-method-name? (car tc))
|
|
(send test-info add-malformed-test (car tc))]
|
|
[(close-to-test-name? (car tc))
|
|
(send test-info add-nearly-testcase (car tc))]
|
|
[else (void)]))
|
|
|
|
(define (test-method? name)
|
|
(and (test-method-name? name) (no-args? name)))
|
|
|
|
(define (test-method-name? name)
|
|
(regexp-match? #rx"^test" (symbol->string name)))
|
|
|
|
(define (no-args? name)
|
|
(not (regexp-match? #rx"-" (symbol->string name))))
|
|
|
|
(define (close-to-test-name? name)
|
|
(let ([n (symbol->string name)])
|
|
(regexp-match? "^(?:tst|tet|Test|tes)" n)))))
|
|
|
|
;(make-test-stat String [U String Src] [listof tests-data] init-testcase-stat [listof tc-stat])
|
|
(define-struct test-stat (name src tests init cases) #:mutable)
|
|
(define-struct tests-data (c-name methods method-srcs))
|
|
;(make-tc-stat String [U String Src] [listof check-info])
|
|
(define-struct tc-stat (name src checks) #:mutable)
|
|
(define-struct (testcase-stat tc-stat) (pass?) #:mutable)
|
|
(define-struct (init-testcase-stat tc-stat) () #:mutable)
|
|
|
|
(define java-test-info%
|
|
(class* test-info-base% ()
|
|
(inherit add-test test-failed)
|
|
|
|
(define test-class-stats null)
|
|
|
|
(define current-testcase #f)
|
|
(define current-test #f)
|
|
|
|
(define/pubment (add-test-class name src)
|
|
(set! current-test (make-test-stat name src null #f null))
|
|
(inner (void) add-test-class name src))
|
|
|
|
(define/public (add-tests-info tests test-methods test-method-srcs)
|
|
(set-test-stat-tests! current-test
|
|
(map make-tests-data
|
|
tests test-methods test-method-srcs)))
|
|
|
|
(define/pubment (complete-test)
|
|
(set! test-class-stats (cons current-test test-class-stats))
|
|
(inner (void) complete-test))
|
|
(define/public (get-current-test) current-test)
|
|
(define/public (get-test-results) test-class-stats)
|
|
|
|
;add-testcase: (U string 'fields) (U string src) -> void
|
|
;adds testcase specific information to the info storage
|
|
(define/pubment (add-testcase name src)
|
|
(set! current-testcase (make-testcase-stat name src null #t))
|
|
(add-test)
|
|
(inner (void) add-testcase name src))
|
|
|
|
(define/pubment (add-inits name src)
|
|
(set! current-testcase (make-init-testcase-stat name src null))
|
|
(inner (void) add-inits name src))
|
|
|
|
(define/pubment (complete-testcase pass?)
|
|
(cond
|
|
[(testcase-stat? current-testcase)
|
|
(set-testcase-stat-pass?! current-testcase pass?)
|
|
(unless pass? (test-failed (get-current-testcase)))
|
|
(set-test-stat-cases! current-test (cons current-testcase
|
|
(test-stat-cases current-test)))]
|
|
[(init-testcase-stat? current-testcase)
|
|
(set-test-stat-init! current-test current-testcase)])
|
|
(inner (void) complete-testcase pass?))
|
|
(define/public (get-current-testcase) current-testcase)
|
|
|
|
(define/augment (check-failed msg src)
|
|
(when current-testcase
|
|
(set-tc-stat-checks!
|
|
current-testcase
|
|
(cons (make-failed-check src msg)
|
|
(tc-stat-checks current-testcase))))
|
|
(inner (void) check-failed msg src))
|
|
|
|
(define/public (format-value value)
|
|
(make-java-snip value (make-format-style #t 'field #f)))
|
|
|
|
(super-instantiate ())))
|
|
|
|
(define java-examples-info%
|
|
(class* java-test-info% ()
|
|
(define nearly-tests null)
|
|
(define nearly-testcases null)
|
|
|
|
(define/public (add-nearly-test name)
|
|
(set! nearly-tests (cons name nearly-tests)))
|
|
(define/public (add-nearly-testcase name)
|
|
(set! nearly-testcases (cons name nearly-testcases)))
|
|
(define/public (close-tests) nearly-tests)
|
|
(define/public (close-testcases) nearly-testcases)
|
|
|
|
(super-instantiate ())))
|
|
|
|
(define (analyzed-test-mixin% test-info-parent)
|
|
(class* test-info-parent ()
|
|
(inherit get-current-test get-current-testcase)
|
|
(inherit-field analyses)
|
|
|
|
(define/augment (add-test-class name src)
|
|
(for ([a analyses]) (send a register-test name src))
|
|
(inner (void) add-test-class name src))
|
|
(define/augment (complete-test)
|
|
(for ([a analyses])
|
|
(send a de-register-test (test-stat-src (get-current-test))))
|
|
(inner (void) complete-test))
|
|
(define/augment (add-testcase name src)
|
|
(for ([a analyses]) (send a register-testcase name src))
|
|
(inner (void) add-testcase name src))
|
|
(define/augment (complete-testcase pass?)
|
|
(for ([a analyses])
|
|
(send a de-register-testcase (tc-stat-src (get-current-testcase))))
|
|
(inner (void) complete-testcase pass?))
|
|
|
|
(super-instantiate ())))
|
|
|
|
(define java-test-display%
|
|
(class* test-display% ()
|
|
|
|
(super-instantiate ())
|
|
(inherit next-line)
|
|
|
|
(define/public (test-name) "tests")
|
|
(define/public (testcase-name) "testcases")
|
|
|
|
(define/pubment (insert-test-name editor test-stat src-editor)
|
|
(send editor insert (test-stat-name test-stat))
|
|
(inner (void) insert-test-name editor test-stat src-editor)
|
|
(send editor insert "\n"))
|
|
|
|
(define/pubment (insert-testcase-name editor testcase-stat src-editor)
|
|
(cond
|
|
[(testcase-stat? testcase-stat)
|
|
(send editor insert (format "~a ~a"
|
|
(tc-stat-name testcase-stat)
|
|
(if (testcase-stat-pass? testcase-stat)
|
|
"succeeded!" "failed.")))]
|
|
[(init-testcase-stat? testcase-stat)
|
|
(send editor insert (format "~a ~a"
|
|
(tc-stat-name testcase-stat)
|
|
" contained failed checks."))]
|
|
[else (void)])
|
|
(inner (void) insert-testcase-name editor testcase-stat src-editor)
|
|
(next-line editor))
|
|
|
|
(define/augment (insert-test-results editor test-info src-editor)
|
|
(inner (void) insert-test-results editor test-info src-editor)
|
|
(insert-tests editor test-info src-editor))
|
|
|
|
(define/pubment (insert-tests editor test-info src-editor)
|
|
(send editor insert
|
|
(format "Ran the following ~a:\n" (send this test-name)))
|
|
(for ([test (send test-info get-test-results)])
|
|
(send editor insert "\n")
|
|
(send this insert-test-name editor test src-editor)
|
|
(when (and (test-stat-init test)
|
|
(not (null? (tc-stat-checks (test-stat-init test)))))
|
|
(send this insert-testcase-name editor (test-stat-init test) src-editor)
|
|
(send this display-check-failures (tc-stat-checks (test-stat-init test))
|
|
editor test-info src-editor)
|
|
(next-line editor))
|
|
(unless (null? (test-stat-cases test))
|
|
(let* ([run-tests (reverse (test-stat-cases test))]
|
|
[num-tests (length run-tests)]
|
|
[failed-tests (filter (compose not testcase-stat-pass?)
|
|
run-tests)])
|
|
(next-line editor)
|
|
(send editor insert
|
|
(format "Ran ~a ~a." num-tests (send this testcase-name)))
|
|
(next-line editor)
|
|
(send editor insert
|
|
(if (null? failed-tests)
|
|
(format "All ~a passed!" (send this testcase-name))
|
|
(format "~a of ~a ~a failed:"
|
|
(length failed-tests) num-tests
|
|
(send this testcase-name))))
|
|
(next-line editor)
|
|
(for ([testcase run-tests])
|
|
(send this insert-testcase-name editor testcase src-editor)
|
|
(if (null? (tc-stat-checks testcase))
|
|
(send editor insert "All checks succeeded!\n")
|
|
(send this display-check-failures
|
|
(tc-stat-checks testcase)
|
|
editor test-info src-editor))
|
|
(next-line editor))
|
|
(inner (void) insert-tests editor test-info src-editor)))))))
|
|
|
|
(define java-examples-display%
|
|
(class* java-test-display% ()
|
|
(super-instantiate ())
|
|
|
|
(define/override (test-name) "Example classes")
|
|
(define/override (testcase-name) "test methods")
|
|
|
|
(define/augment (insert-tests editor test-info src-editor)
|
|
(unless (null? (send test-info close-tests))
|
|
(send editor insert "\n")
|
|
(send editor insert "The following classes were not run, but are similar to example classes:\n")
|
|
(for ([name (send test-info close-tests)])
|
|
(send editor insert (format "\t~a\n" name))))
|
|
(inner (void) insert-tests editor test-info src-editor))))
|
|
|
|
(define (java-coverage-display-mixin parent)
|
|
(class* parent ()
|
|
|
|
(field (coverage-info #f))
|
|
(inherit insert-covered-button)
|
|
|
|
(define/augment (install-info t)
|
|
(let ([info (send t extract-info (lambda (a) (is-a? a coverage-track%)))])
|
|
(unless (null? info) (set! coverage-info (car info))))
|
|
(inner (void) install-info t))
|
|
|
|
(define/augment (insert-test-results editor test-info src-editor)
|
|
(insert-covered-button editor coverage-info #f src-editor #f)
|
|
(send editor insert "\n")
|
|
(inner (void) insert-test-results editor test-info src-editor))
|
|
|
|
(define/augment (insert-test-name editor test-stat src-editor)
|
|
(insert-covered-button editor coverage-info (test-stat-src test-stat)
|
|
src-editor #t)
|
|
(send editor insert "\n")
|
|
(for ([tested (test-stat-tests test-stat)])
|
|
(unless (send coverage-info covers-spans
|
|
(tests-data-method-srcs tested))
|
|
(send editor insert
|
|
(format-uncovered-message (test-stat-name test-stat)
|
|
(tests-data-c-name tested)))
|
|
(for ([sub (tests-data-methods tested)]
|
|
[sub-span (tests-data-method-srcs tested)])
|
|
(send editor insert
|
|
(if (send coverage-info covers-span sub-span)
|
|
(format-covered-sub sub)
|
|
(format-uncovered-sub sub))))))
|
|
(inner (void) insert-test-name editor test-stat src-editor))
|
|
|
|
(define (format-uncovered-message test tests)
|
|
(format "test ~a failed to fully cover tested class ~a" test tests))
|
|
(define (format-covered-sub method)
|
|
(format "method ~a is fully covered" method))
|
|
(define (format-uncovered-sub method)
|
|
(format "method ~a is not fully covered" method))
|
|
|
|
|
|
(define/augride (insert-testcase-name editor testcase-stat src-editor)
|
|
(insert-covered-button editor coverage-info
|
|
(tc-stat-src testcase-stat)
|
|
src-editor #t))
|
|
|
|
(super-instantiate ())))
|
|
|
|
(define java-test-base% (java-test (analyzed-test-mixin% java-test-info%)))
|
|
(define java-test-graphics% java-test-display%)
|
|
(define java-test-coverage-graphics%
|
|
(java-coverage-display-mixin
|
|
(test-coverage-button-mixin java-test-display%)))
|
|
|
|
(define java-examples-engine%
|
|
(java-examples (analyzed-test-mixin% java-examples-info%)))
|
|
(define java-examples-graphics% java-examples-display%)
|
|
(define java-examples-coverage-graphics%
|
|
(java-coverage-display-mixin
|
|
(test-coverage-button-mixin java-examples-display%)))
|
|
|
|
(provide java-test-base%
|
|
java-test-graphics%
|
|
java-test-coverage-graphics%
|
|
java-examples-engine%
|
|
java-examples-graphics%
|
|
java-examples-coverage-graphics%)
|