formatting, v4-isms, props, etc
svn: r9168
This commit is contained in:
Eli Barzilay
parent
a3d8cb9447
commit
22f506d718
|
|
@ -1,5 +1,4 @@
|
|||
(module info setup/infotab
|
||||
(define name "Test Engine")
|
||||
(define tools (list (list "test-tool.scm")))
|
||||
(define tool-names '("Test Engine"))
|
||||
)
|
||||
#lang setup/infotab
|
||||
|
||||
(define tools (list (list "test-tool.scm")))
|
||||
(define tool-names '("Test Engine"))
|
||||
|
|
|
|||
|
|
@ -1,349 +1,346 @@
|
|||
(module java-tests scheme/base
|
||||
|
||||
(require scheme/class
|
||||
(lib "etc.ss")
|
||||
(lib "display-java.ss" "profj"))
|
||||
(require "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-each (lambda (t) (initialize-test t)) tests)
|
||||
(inner (void) run)
|
||||
(for-each (lambda (t) (run-test t)) tests))
|
||||
|
||||
))
|
||||
|
||||
(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)])
|
||||
(send test-info add-test-class test-name test-src) ;need to run constructor
|
||||
(let ([test-obj (make-object test-class)])
|
||||
(set! test-objs (cons test-obj test-objs))
|
||||
(for-each (lambda (tc) (run-testcase tc))
|
||||
(send test-obj testMethods))
|
||||
(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))))
|
||||
#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)
|
||||
(let ([test-obj (make-object test-class)])
|
||||
(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-each (lambda (tc) (run-testcase tc))
|
||||
(build-testcases test-obj))
|
||||
(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 "^test" (symbol->string name)))
|
||||
|
||||
(define (no-args? name)
|
||||
(not (regexp-match "-" (symbol->string name))))
|
||||
|
||||
(define (close-to-test-name? name)
|
||||
(let ((n (symbol->string name)))
|
||||
(or (regexp-match "^tst" n)
|
||||
(regexp-match "^tet" n)
|
||||
(regexp-match "^Test" n)
|
||||
(regexp-match "^tes" n))))
|
||||
|
||||
|
||||
))
|
||||
|
||||
(define-struct test-stat (name src tests cases) #:mutable)
|
||||
(define-struct tests-data (c-name methods method-srcs))
|
||||
(define-struct testcase-stat (name src pass? checks) #: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 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)
|
||||
|
||||
(define/pubment (add-testcase name src)
|
||||
(set! current-testcase (make-testcase-stat name src #t null))
|
||||
(add-test)
|
||||
(inner (void) add-testcase name src))
|
||||
|
||||
(define/pubment (complete-testcase pass?)
|
||||
(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)))
|
||||
(inner (void) complete-testcase pass?))
|
||||
(define/public (get-current-testcase) current-testcase)
|
||||
|
||||
(define/augment (check-failed msg src)
|
||||
(when current-testcase
|
||||
(set-testcase-stat-checks!
|
||||
current-testcase
|
||||
(cons (make-failed-check src msg) (testcase-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-each (lambda (a) (send a register-test name src)) analyses)
|
||||
(inner (void) add-test-class name src))
|
||||
(define/augment (complete-test)
|
||||
(for-each (lambda (a) (send a de-register-test (test-stat-src (get-current-test)))) analyses)
|
||||
(inner (void) complete-test))
|
||||
(define/augment (add-testcase name src)
|
||||
(for-each (lambda (a) (send a register-testcase name src)) analyses)
|
||||
(inner (void) add-testcase name src))
|
||||
(define/augment (complete-testcase pass?)
|
||||
(for-each (lambda (a) (send a de-register-testcase (testcase-stat-src (get-current-testcase)))) analyses)
|
||||
(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)
|
||||
(send editor insert (format "~a ~a"
|
||||
(testcase-stat-name testcase-stat)
|
||||
(if (testcase-stat-pass? testcase-stat) "succeeded!" "failed")))
|
||||
(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-each
|
||||
(lambda (test)
|
||||
(send editor insert "\n")
|
||||
(send this insert-test-name editor test src-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)
|
||||
(if (null? failed-tests)
|
||||
(send editor insert (format "All ~a passed!" (send this testcase-name)))
|
||||
(send editor insert (format "~a of ~a ~a failed:"
|
||||
(length failed-tests) num-tests
|
||||
(send this testcase-name))))
|
||||
(next-line editor)
|
||||
(for-each
|
||||
(lambda (testcase)
|
||||
(send this insert-testcase-name editor testcase src-editor)
|
||||
(cond
|
||||
[(null? (testcase-stat-checks testcase))
|
||||
(send editor insert "All checks succeeded!\n")]
|
||||
[else
|
||||
(send this display-check-failures (testcase-stat-checks testcase)
|
||||
editor test-info src-editor)])
|
||||
(next-line editor))
|
||||
run-tests)
|
||||
(inner (void) insert-tests editor test-info src-editor))))
|
||||
(send test-info get-test-results)
|
||||
))
|
||||
))
|
||||
|
||||
(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-each (lambda (name) (send editor insert (format "\t~a\n" name)))
|
||||
(send test-info close-tests)))
|
||||
(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-each
|
||||
(lambda (tested)
|
||||
(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-each (lambda (sub sub-span)
|
||||
(if (send coverage-info covers-span sub-span)
|
||||
(send editor insert (format-covered-sub sub))
|
||||
(send editor insert (format-uncovered-sub sub))))
|
||||
(tests-data-methods tested)
|
||||
(tests-data-method-srcs tested))))
|
||||
(test-stat-tests test-stat))
|
||||
(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 (testcase-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%)))
|
||||
(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)))))
|
||||
|
||||
(provide java-test-base% java-test-graphics% java-test-coverage-graphics%
|
||||
java-examples-engine% java-examples-graphics% java-examples-coverage-graphics%)
|
||||
|
||||
)
|
||||
(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)
|
||||
(let ([test-obj (make-object test-class)])
|
||||
(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)))))
|
||||
|
||||
(define-struct test-stat (name src tests cases) #:mutable)
|
||||
(define-struct tests-data (c-name methods method-srcs))
|
||||
(define-struct testcase-stat (name src pass? checks) #: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 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)
|
||||
|
||||
(define/pubment (add-testcase name src)
|
||||
(set! current-testcase (make-testcase-stat name src #t null))
|
||||
(add-test)
|
||||
(inner (void) add-testcase name src))
|
||||
|
||||
(define/pubment (complete-testcase pass?)
|
||||
(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)))
|
||||
(inner (void) complete-testcase pass?))
|
||||
(define/public (get-current-testcase) current-testcase)
|
||||
|
||||
(define/augment (check-failed msg src)
|
||||
(when current-testcase
|
||||
(set-testcase-stat-checks!
|
||||
current-testcase
|
||||
(cons (make-failed-check src msg)
|
||||
(testcase-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 (testcase-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)
|
||||
(send editor insert (format "~a ~a"
|
||||
(testcase-stat-name testcase-stat)
|
||||
(if (testcase-stat-pass? testcase-stat)
|
||||
"succeeded!" "failed")))
|
||||
(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)
|
||||
(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? (testcase-stat-checks testcase))
|
||||
(send editor insert "All checks succeeded!\n")
|
||||
(send this display-check-failures
|
||||
(testcase-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
|
||||
(testcase-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%)
|
||||
|
|
|
|||
|
|
@ -1,34 +1,31 @@
|
|||
(module scheme-gui scheme/base
|
||||
|
||||
(require scheme/class)
|
||||
(require "test-engine.scm")
|
||||
|
||||
(define scheme-test-data (make-parameter (list #f #f)))
|
||||
|
||||
(define scheme-test%
|
||||
(class* test-engine% ()
|
||||
|
||||
(super-instantiate ())
|
||||
(inherit-field test-info test-display)
|
||||
(inherit setup-info)
|
||||
|
||||
(field [tests null]
|
||||
[test-objs null])
|
||||
|
||||
(define/public (add-test tst)
|
||||
(set! tests (cons tst tests)))
|
||||
(define/public (get-info)
|
||||
(unless test-info (send this setup-info 'check-require))
|
||||
test-info)
|
||||
|
||||
(define/augment (run)
|
||||
(inner (void) run)
|
||||
(for-each (lambda (t) (run-test t)) (reverse tests)))
|
||||
|
||||
(define/augment (run-test test) (test)
|
||||
(inner (void) run-test test))
|
||||
|
||||
))
|
||||
|
||||
(provide scheme-test% scheme-test-data)
|
||||
)
|
||||
#lang scheme/base
|
||||
|
||||
(require scheme/class
|
||||
"test-engine.scm")
|
||||
|
||||
(define scheme-test-data (make-parameter (list #f #f)))
|
||||
|
||||
(define scheme-test%
|
||||
(class* test-engine% ()
|
||||
(super-instantiate ())
|
||||
(inherit-field test-info test-display)
|
||||
(inherit setup-info)
|
||||
|
||||
(field [tests null]
|
||||
[test-objs null])
|
||||
|
||||
(define/public (add-test tst)
|
||||
(set! tests (cons tst tests)))
|
||||
(define/public (get-info)
|
||||
(unless test-info (send this setup-info 'check-require))
|
||||
test-info)
|
||||
|
||||
(define/augment (run)
|
||||
(inner (void) run)
|
||||
(for ([t (reverse tests)]) (run-test t)))
|
||||
|
||||
(define/augment (run-test test)
|
||||
(test)
|
||||
(inner (void) run-test test))))
|
||||
|
||||
(provide scheme-test% scheme-test-data)
|
||||
|
|
|
|||
|
|
@ -1,276 +1,287 @@
|
|||
(module scheme-tests mzscheme
|
||||
#lang mzscheme
|
||||
|
||||
(require (lib "teachprims.ss" "lang" "private")
|
||||
mred
|
||||
framework
|
||||
mzlib/pretty
|
||||
mzlib/pconvert
|
||||
mzlib/class)
|
||||
|
||||
(require "scheme-gui.scm"
|
||||
"test-display.scm")
|
||||
|
||||
(require-for-syntax (lib "shared.ss" "stepper" "private"))
|
||||
|
||||
(provide
|
||||
check-expect ;; syntax : (check-expect <expression> <expression>)
|
||||
check-within ;; syntax : (check-within <expression> <expression> <expression>)
|
||||
check-error ;; syntax : (check-error <expression> <expression>)
|
||||
|
||||
)
|
||||
(require lang/private/teachprims
|
||||
mred
|
||||
framework
|
||||
mzlib/pretty
|
||||
mzlib/pconvert
|
||||
mzlib/class
|
||||
"scheme-gui.scm"
|
||||
"test-display.scm")
|
||||
|
||||
(define builder
|
||||
(lambda ()
|
||||
(let ([te (build-test-engine)])
|
||||
(namespace-set-variable-value! 'test~object te (current-namespace))
|
||||
te)))
|
||||
|
||||
(define (test)
|
||||
(run-tests)
|
||||
(display-results))
|
||||
|
||||
(define (test-text)
|
||||
(run-tests)
|
||||
(print-results))
|
||||
|
||||
(define-syntax (run-tests stx)
|
||||
(syntax-case stx ()
|
||||
((_)
|
||||
(syntax-property
|
||||
#'(run (namespace-variable-value 'test~object #f builder (current-namespace)))
|
||||
'test-call #t))))
|
||||
|
||||
(define (run test-info) (and test-info (send test-info run)))
|
||||
|
||||
(define-syntax (display-results stx)
|
||||
(syntax-case stx ()
|
||||
((_)
|
||||
(syntax-property
|
||||
#'(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))])
|
||||
(and test-info
|
||||
(let ([display-data (scheme-test-data)])
|
||||
(send test-info setup-display (car display-data) (cadr display-data))
|
||||
(send test-info summarize-results (current-output-port)))))
|
||||
'test-call #t))))
|
||||
(require-for-syntax stepper/private/shared)
|
||||
|
||||
(define-syntax (print-results stx)
|
||||
(syntax-case stx ()
|
||||
((_)
|
||||
(syntax-property
|
||||
#'(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))))
|
||||
(provide
|
||||
check-expect ;; syntax : (check-expect <expression> <expression>)
|
||||
check-within ;; syntax : (check-within <expression> <expression> <expression>)
|
||||
check-error ;; syntax : (check-error <expression> <expression>)
|
||||
)
|
||||
|
||||
|
||||
(provide run-tests display-results test test-text)
|
||||
|
||||
(define (build-test-engine)
|
||||
(let ([engine (make-object scheme-test%)])
|
||||
(send engine setup-info 'check-require)
|
||||
engine))
|
||||
(define (insert-test test-info test) (send test-info add-test test))
|
||||
|
||||
(define INEXACT-NUMBERS-FMT
|
||||
"check-expect cannot compare inexact numbers. Try (check-within test ~a range).")
|
||||
(define CHECK-ERROR-STR-FMT
|
||||
"check-error requires a string for the second argument, representing the expected error message. Given ~s")
|
||||
(define CHECK-WITHIN-INEXACT-FMT
|
||||
"check-within requires an inexact number for the range. ~a is not inexact.")
|
||||
(define (builder)
|
||||
(let ([te (build-test-engine)])
|
||||
(namespace-set-variable-value! 'test~object te (current-namespace))
|
||||
te))
|
||||
|
||||
(define-for-syntax CHECK-EXPECT-STR
|
||||
"check-expect requires two expressions. Try (check-expect test expected).")
|
||||
(define-for-syntax CHECK-ERROR-STR
|
||||
"check-error requires two expressions. Try (check-error test message).")
|
||||
(define-for-syntax CHECK-WITHIN-STR
|
||||
"check-within requires three expressions. Try (check-within test expected range).")
|
||||
|
||||
(define-for-syntax CHECK-EXPECT-DEFN-STR
|
||||
"check-expect cannot be used as an expression")
|
||||
(define-for-syntax CHECK-WITHIN-DEFN-STR
|
||||
"check-within cannot be used as an expression")
|
||||
(define-for-syntax CHECK-ERROR-DEFN-STR
|
||||
"check-error cannot be used as an expression")
|
||||
|
||||
(define-struct check-fail (src))
|
||||
(define (test)
|
||||
(run-tests)
|
||||
(display-results))
|
||||
|
||||
;(make-unexpected-error src string)
|
||||
(define-struct (unexpected-error check-fail) (expected message))
|
||||
;(make-unequal src scheme-val scheme-val)
|
||||
(define-struct (unequal check-fail) (test actual))
|
||||
;(make-outofrange src scheme-val scheme-val inexact)
|
||||
(define-struct (outofrange check-fail) (test actual range))
|
||||
;(make-incorrect-error src string)
|
||||
(define-struct (incorrect-error check-fail) (expected message))
|
||||
;(make-expected-error src string scheme-val)
|
||||
(define-struct (expected-error check-fail) (message value))
|
||||
|
||||
(define-syntax (check-expect stx)
|
||||
(syntax-case stx ()
|
||||
((_ test actual)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(quasisyntax/loc stx
|
||||
(define #,(gensym 'test)
|
||||
#,(stepper-syntax-property
|
||||
#`(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))])
|
||||
(when test-info
|
||||
(insert-test test-info
|
||||
(lambda ()
|
||||
(check-values-expected
|
||||
(lambda () test)
|
||||
actual
|
||||
(list #,@(list #`(quote #,(syntax-source stx))
|
||||
(syntax-line stx)
|
||||
(syntax-column stx)
|
||||
(syntax-position stx)
|
||||
(syntax-span stx)))
|
||||
test-info)))))
|
||||
`stepper-hint
|
||||
`comes-from-check-expect))))
|
||||
((_ test)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(raise-syntax-error 'check-expect CHECK-EXPECT-STR stx))
|
||||
((_ test actual extra ...)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(raise-syntax-error 'check-expect CHECK-EXPECT-STR stx))
|
||||
((_ test ...)
|
||||
(eq? (syntax-local-context) 'expression)
|
||||
(raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx))))
|
||||
(define (test-text)
|
||||
(run-tests)
|
||||
(print-results))
|
||||
|
||||
;check-values-expected: (-> scheme-val) scheme-val src -> void
|
||||
(define (check-values-expected test actual src test-info)
|
||||
(error-check (lambda (v) (if (number? v) (exact? v) #t))
|
||||
actual INEXACT-NUMBERS-FMT)
|
||||
(send (send test-info get-info) add-check)
|
||||
(run-and-check (lambda (v1 v2 _) (beginner-equal? v1 v2))
|
||||
(lambda (src v1 v2 _) (make-unequal src v1 v2))
|
||||
test actual #f src test-info))
|
||||
|
||||
(define-syntax (check-within stx)
|
||||
(syntax-case stx ()
|
||||
((_ test actual within)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(quasisyntax/loc stx
|
||||
(define #,(gensym 'test-within)
|
||||
(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))])
|
||||
(when test-info
|
||||
(insert test-info
|
||||
(lambda ()
|
||||
(check-values-within (lambda () test) actual within
|
||||
(list #,@(list (syntax-source stx)
|
||||
(syntax-line stx)
|
||||
(syntax-column stx)
|
||||
(syntax-position stx)
|
||||
(syntax-span stx)))
|
||||
test-info))))))))
|
||||
((_ test actual)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(raise-syntax-error 'check-within CHECK-WITHIN-STR stx))
|
||||
((_ test)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(raise-syntax-error 'check-within CHECK-WITHIN-STR stx))
|
||||
((_ test actual within extra ...)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(raise-syntax-error 'check-within CHECK-WITHIN-STR stx))
|
||||
((_ test ...)
|
||||
(eq? (syntax-local-context) 'expression)
|
||||
(raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx))))
|
||||
(define-syntax (run-tests stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(syntax-property
|
||||
#'(run (namespace-variable-value 'test~object #f builder
|
||||
(current-namespace)))
|
||||
'test-call #t)]))
|
||||
|
||||
(define (check-values-within test actual within src test-info)
|
||||
(error-check number? within CHECK-WITHIN-INEXACT-FMT)
|
||||
(send (send test-info get-info) add-check)
|
||||
(run-and-check beginner-equal~? make-outofrange test actual within src test-info))
|
||||
(define (run test-info) (and test-info (send test-info run)))
|
||||
|
||||
(define-syntax (check-error stx)
|
||||
(syntax-case stx ()
|
||||
((_ test error)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(quasisyntax/loc stx
|
||||
(define #,(gensym 'test-error)
|
||||
(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))])
|
||||
(when test-info
|
||||
(insert-test test-info
|
||||
(lambda ()
|
||||
(check-values-error (lambda () test) error (list #,@(list (syntax-source stx)
|
||||
(syntax-line stx)
|
||||
(syntax-column stx)
|
||||
(syntax-position stx)
|
||||
(syntax-span stx)))
|
||||
test-info))))))))
|
||||
((_ test)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(raise-syntax-error 'check-error CHECK-ERROR-STR stx))
|
||||
((_ test ...)
|
||||
(eq? (syntax-local-context) 'expression)
|
||||
(raise-syntax-error 'check-error CHECK-ERROR-DEFN-STR stx))))
|
||||
(define-syntax (display-results stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(syntax-property
|
||||
#'(let ([test-info (namespace-variable-value 'test~object #f builder
|
||||
(current-namespace))])
|
||||
(and test-info
|
||||
(let ([display-data (scheme-test-data)])
|
||||
(send test-info setup-display
|
||||
(car display-data) (cadr display-data))
|
||||
(send test-info summarize-results (current-output-port)))))
|
||||
'test-call #t)]))
|
||||
|
||||
(define (check-values-error test error src test-info)
|
||||
(error-check string? error CHECK-ERROR-STR-FMT)
|
||||
(send (send test-info get-info) add-check)
|
||||
(let ([result (with-handlers ((exn?
|
||||
(lambda (e)
|
||||
(or (equal? (exn-message e) error)
|
||||
(make-incorrect-error src error (exn-message e))))))
|
||||
(let ([test-val (test)])
|
||||
(make-expected-error src error test-val)))])
|
||||
(when (check-fail? result)
|
||||
(send (send test-info get-info) check-failed (check->message result) (check-fail-src result)))))
|
||||
(define-syntax (print-results stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(syntax-property
|
||||
#'(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)]))
|
||||
|
||||
(define (error-check pred? actual fmt)
|
||||
(unless (pred? actual)
|
||||
(raise (make-exn:fail:contract (format fmt actual)
|
||||
(current-continuation-marks)))))
|
||||
|
||||
;run-and-check: (scheme-val scheme-val scheme-val -> boolean)
|
||||
; (scheme-val scheme-val scheme-val -> check-fail)
|
||||
; ( -> scheme-val) scheme-val scheme-val object -> void
|
||||
(define (run-and-check check maker test expect range src test-info)
|
||||
(let ([result
|
||||
(with-handlers ((exn? (lambda (e) (make-unexpected-error src expect (exn-message e)))))
|
||||
(let ([test-val (test)])
|
||||
(or (check test-val expect range)
|
||||
(maker src test-val expect range))))])
|
||||
(when (check-fail? result)
|
||||
(send (send test-info get-info) check-failed (check->message result) (check-fail-src result)))))
|
||||
|
||||
(define (check->message fail)
|
||||
(cond
|
||||
[(unexpected-error? fail)
|
||||
(list "check encountered the following error instead of the expected value, "
|
||||
(format-value (unexpected-error-expected fail))
|
||||
(format ". ~n :: ~a~n" (unexpected-error-message fail)))]
|
||||
[(unequal? fail)
|
||||
(list "Actual value "
|
||||
(format-value (unequal-test fail))
|
||||
" differs from "
|
||||
(format-value (unequal-actual fail))
|
||||
", the expected value.\n")]
|
||||
[(outofrange? fail)
|
||||
(list "Actual value "
|
||||
(format-value (outofrange-test fail))
|
||||
(format " is not within ~v of expected value " (outofrange-range fail))
|
||||
(format-value (outofrange-actual fail))
|
||||
".\n")]
|
||||
[(incorrect-error? fail)
|
||||
(list (format "check-error encountered the following error instead of the expected ~a~n :: ~a ~n"
|
||||
(incorrect-error-expected fail) (incorrect-error-message fail)))]
|
||||
[(expected-error? fail)
|
||||
(list "check-error expected the following error, but instead received the value "
|
||||
(format-value (expected-error-value fail))
|
||||
(format ".~n ~a~n" (expected-error-message fail)))]))
|
||||
|
||||
(define (format-value value)
|
||||
(cond
|
||||
[(is-a? value snip%) value]
|
||||
[(or (pair? value) (struct? value))
|
||||
(parameterize ([constructor-style-printing #t]
|
||||
[pretty-print-columns 40])
|
||||
(let* ([text* (new (editor:standard-style-list-mixin text%))]
|
||||
[text-snip (new editor-snip% [editor text*])])
|
||||
(pretty-print (print-convert value) (open-output-text-editor text*))
|
||||
(send text* lock #t)
|
||||
text-snip))]
|
||||
[else (format "~v" value)]))
|
||||
|
||||
)
|
||||
(provide run-tests display-results test test-text)
|
||||
|
||||
(define (build-test-engine)
|
||||
(let ([engine (make-object scheme-test%)])
|
||||
(send engine setup-info 'check-require)
|
||||
engine))
|
||||
(define (insert-test test-info test) (send test-info add-test test))
|
||||
|
||||
(define INEXACT-NUMBERS-FMT
|
||||
"check-expect cannot compare inexact numbers. Try (check-within test ~a range).")
|
||||
(define CHECK-ERROR-STR-FMT
|
||||
"check-error requires a string for the second argument, representing the expected error message. Given ~s")
|
||||
(define CHECK-WITHIN-INEXACT-FMT
|
||||
"check-within requires an inexact number for the range. ~a is not inexact.")
|
||||
|
||||
(define-for-syntax CHECK-EXPECT-STR
|
||||
"check-expect requires two expressions. Try (check-expect test expected).")
|
||||
(define-for-syntax CHECK-ERROR-STR
|
||||
"check-error requires two expressions. Try (check-error test message).")
|
||||
(define-for-syntax CHECK-WITHIN-STR
|
||||
"check-within requires three expressions. Try (check-within test expected range).")
|
||||
|
||||
(define-for-syntax CHECK-EXPECT-DEFN-STR
|
||||
"check-expect cannot be used as an expression")
|
||||
(define-for-syntax CHECK-WITHIN-DEFN-STR
|
||||
"check-within cannot be used as an expression")
|
||||
(define-for-syntax CHECK-ERROR-DEFN-STR
|
||||
"check-error cannot be used as an expression")
|
||||
|
||||
(define-struct check-fail (src))
|
||||
|
||||
;; (make-unexpected-error src string)
|
||||
(define-struct (unexpected-error check-fail) (expected message))
|
||||
;; (make-unequal src scheme-val scheme-val)
|
||||
(define-struct (unequal check-fail) (test actual))
|
||||
;; (make-outofrange src scheme-val scheme-val inexact)
|
||||
(define-struct (outofrange check-fail) (test actual range))
|
||||
;; (make-incorrect-error src string)
|
||||
(define-struct (incorrect-error check-fail) (expected message))
|
||||
;; (make-expected-error src string scheme-val)
|
||||
(define-struct (expected-error check-fail) (message value))
|
||||
|
||||
(define-syntax (check-expect stx)
|
||||
(syntax-case stx ()
|
||||
[(_ test actual)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(quasisyntax/loc stx
|
||||
(define #,(gensym 'test)
|
||||
#,(stepper-syntax-property
|
||||
#`(let ([test-info (namespace-variable-value
|
||||
'test~object #f builder (current-namespace))])
|
||||
(when test-info
|
||||
(insert-test test-info
|
||||
(lambda ()
|
||||
(check-values-expected
|
||||
(lambda () test)
|
||||
actual
|
||||
(list #,@(list #`(quote #,(syntax-source stx))
|
||||
(syntax-line stx)
|
||||
(syntax-column stx)
|
||||
(syntax-position stx)
|
||||
(syntax-span stx)))
|
||||
test-info)))))
|
||||
`stepper-hint
|
||||
`comes-from-check-expect)))]
|
||||
[(_ test)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)]
|
||||
[(_ test actual extra ...)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)]
|
||||
[(_ test ...)
|
||||
(eq? (syntax-local-context) 'expression)
|
||||
(raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx)]))
|
||||
|
||||
;; check-values-expected: (-> scheme-val) scheme-val src -> void
|
||||
(define (check-values-expected test actual src test-info)
|
||||
(error-check (lambda (v) (if (number? v) (exact? v) #t))
|
||||
actual INEXACT-NUMBERS-FMT)
|
||||
(send (send test-info get-info) add-check)
|
||||
(run-and-check (lambda (v1 v2 _) (beginner-equal? v1 v2))
|
||||
(lambda (src v1 v2 _) (make-unequal src v1 v2))
|
||||
test actual #f src test-info))
|
||||
|
||||
(define-syntax (check-within stx)
|
||||
(syntax-case stx ()
|
||||
[(_ test actual within)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(quasisyntax/loc stx
|
||||
(define #,(gensym 'test-within)
|
||||
(let ([test-info (namespace-variable-value
|
||||
'test~object #f builder (current-namespace))])
|
||||
(when test-info
|
||||
(insert test-info
|
||||
(lambda ()
|
||||
(check-values-within
|
||||
(lambda () test) actual within
|
||||
(list #,@(list (syntax-source stx)
|
||||
(syntax-line stx)
|
||||
(syntax-column stx)
|
||||
(syntax-position stx)
|
||||
(syntax-span stx)))
|
||||
test-info)))))))]
|
||||
[(_ test actual)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]
|
||||
[(_ test)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]
|
||||
[(_ test actual within extra ...)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]
|
||||
[(_ test ...)
|
||||
(eq? (syntax-local-context) 'expression)
|
||||
(raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx)]))
|
||||
|
||||
(define (check-values-within test actual within src test-info)
|
||||
(error-check number? within CHECK-WITHIN-INEXACT-FMT)
|
||||
(send (send test-info get-info) add-check)
|
||||
(run-and-check beginner-equal~? make-outofrange test actual within src
|
||||
test-info))
|
||||
|
||||
(define-syntax (check-error stx)
|
||||
(syntax-case stx ()
|
||||
[(_ test error)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(quasisyntax/loc stx
|
||||
(define #,(gensym 'test-error)
|
||||
(let ([test-info (namespace-variable-value
|
||||
'test~object #f builder (current-namespace))])
|
||||
(when test-info
|
||||
(insert-test test-info
|
||||
(lambda ()
|
||||
(check-values-error
|
||||
(lambda () test) error
|
||||
(list #,@(list (syntax-source stx)
|
||||
(syntax-line stx)
|
||||
(syntax-column stx)
|
||||
(syntax-position stx)
|
||||
(syntax-span stx)))
|
||||
test-info)))))))]
|
||||
[(_ test)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(raise-syntax-error 'check-error CHECK-ERROR-STR stx)]
|
||||
[(_ test ...)
|
||||
(eq? (syntax-local-context) 'expression)
|
||||
(raise-syntax-error 'check-error CHECK-ERROR-DEFN-STR stx)]))
|
||||
|
||||
(define (check-values-error test error src test-info)
|
||||
(error-check string? error CHECK-ERROR-STR-FMT)
|
||||
(send (send test-info get-info) add-check)
|
||||
(let ([result (with-handlers ([exn?
|
||||
(lambda (e)
|
||||
(or (equal? (exn-message e) error)
|
||||
(make-incorrect-error src error
|
||||
(exn-message e))))])
|
||||
(let ([test-val (test)])
|
||||
(make-expected-error src error test-val)))])
|
||||
(when (check-fail? result)
|
||||
(send (send test-info get-info) check-failed
|
||||
(check->message result) (check-fail-src result)))))
|
||||
|
||||
(define (error-check pred? actual fmt)
|
||||
(unless (pred? actual)
|
||||
(raise (make-exn:fail:contract (format fmt actual)
|
||||
(current-continuation-marks)))))
|
||||
|
||||
;; run-and-check: (scheme-val scheme-val scheme-val -> boolean)
|
||||
;; (scheme-val scheme-val scheme-val -> check-fail)
|
||||
;; ( -> scheme-val) scheme-val scheme-val object -> void
|
||||
(define (run-and-check check maker test expect range src test-info)
|
||||
(let ([result
|
||||
(with-handlers ([exn? (lambda (e)
|
||||
(make-unexpected-error src expect
|
||||
(exn-message e)))])
|
||||
(let ([test-val (test)])
|
||||
(or (check test-val expect range)
|
||||
(maker src test-val expect range))))])
|
||||
(when (check-fail? result)
|
||||
(send (send test-info get-info) check-failed (check->message result)
|
||||
(check-fail-src result)))))
|
||||
|
||||
(define (check->message fail)
|
||||
(cond
|
||||
[(unexpected-error? fail)
|
||||
(list "check encountered the following error instead of the expected value, "
|
||||
(format-value (unexpected-error-expected fail))
|
||||
(format ". ~n :: ~a~n" (unexpected-error-message fail)))]
|
||||
[(unequal? fail)
|
||||
(list "Actual value "
|
||||
(format-value (unequal-test fail))
|
||||
" differs from "
|
||||
(format-value (unequal-actual fail))
|
||||
", the expected value.\n")]
|
||||
[(outofrange? fail)
|
||||
(list "Actual value "
|
||||
(format-value (outofrange-test fail))
|
||||
(format " is not within ~v of expected value " (outofrange-range fail))
|
||||
(format-value (outofrange-actual fail))
|
||||
".\n")]
|
||||
[(incorrect-error? fail)
|
||||
(list (format "check-error encountered the following error instead of the expected ~a~n :: ~a ~n"
|
||||
(incorrect-error-expected fail)
|
||||
(incorrect-error-message fail)))]
|
||||
[(expected-error? fail)
|
||||
(list "check-error expected the following error, but instead received the value "
|
||||
(format-value (expected-error-value fail))
|
||||
(format ".~n ~a~n" (expected-error-message fail)))]))
|
||||
|
||||
(define (format-value value)
|
||||
(cond
|
||||
[(is-a? value snip%) value]
|
||||
[(or (pair? value) (struct? value))
|
||||
(parameterize ([constructor-style-printing #t]
|
||||
[pretty-print-columns 40])
|
||||
(let* ([text* (new (editor:standard-style-list-mixin text%))]
|
||||
[text-snip (new editor-snip% [editor text*])])
|
||||
(pretty-print (print-convert value) (open-output-text-editor text*))
|
||||
(send text* lock #t)
|
||||
text-snip))]
|
||||
[else (format "~v" value)]))
|
||||
|
|
|
|||
|
|
@ -1,142 +1,139 @@
|
|||
(module test-coverage mzscheme
|
||||
|
||||
(require (lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(prefix list: (lib "list.ss"))
|
||||
(lib "integer-set.ss"))
|
||||
|
||||
(provide (all-defined))
|
||||
|
||||
(define coverage-track%
|
||||
(class* object% ()
|
||||
|
||||
(super-instantiate ())
|
||||
|
||||
(define covered (make-range)) ; interger-set
|
||||
(define covered-from-src (make-hash-table 'weak));[hashtable-of scheme-val -> integer-set]
|
||||
(define current-coverage-srcs null); (listof covered-from-src keys)
|
||||
|
||||
(define/public (covered-position start span)
|
||||
(let ([new-range (make-range start (+ start span))])
|
||||
(set! covered (union covered new-range))
|
||||
(for-each (lambda (key covered-set)
|
||||
(hash-table-put! covered-from-src key (union covered-set new-range)))
|
||||
current-coverage-srcs
|
||||
(map (lambda (key) (hash-table-get covered-from-src key (make-range)))
|
||||
current-coverage-srcs))))
|
||||
|
||||
(define/public (register-coverage-point src)
|
||||
(set! current-coverage-srcs (cons src current-coverage-srcs)))
|
||||
|
||||
(define/public (unregister-coverage-point src)
|
||||
(set! current-coverage-srcs (list:remq src current-coverage-srcs)))
|
||||
|
||||
(define/public (covers-span? start span)
|
||||
(zero? (card (difference (make-range start (+ start span)) covered))))
|
||||
|
||||
(define/public (covers-spans? srcs)
|
||||
(andmap (lambda (s) (covers-span? (car s) (cdr s))) srcs))
|
||||
|
||||
(define/public (display-coverage editor)
|
||||
(highlight-covered editor covered))
|
||||
|
||||
(define/public (display-covered-portion editor coverage-point)
|
||||
(highlight-covered editor (hash-table-get covered-from-src coverage-point (make-range))))
|
||||
|
||||
|
||||
(define/private (highlight-covered editor int-set)
|
||||
(let* ([style-list (editor:get-standard-style-list)]
|
||||
[uncovered-highlight (send style-list find-named-style
|
||||
"profj:syntax-colors:scheme:uncovered")]
|
||||
[covered-highlight (send style-list find-named-style
|
||||
"profj:syntax-colors:scheme:covered")])
|
||||
(letrec ([color-buff
|
||||
(lambda ()
|
||||
(cond
|
||||
((or (send editor is-locked?) (send editor in-edit-sequence?))
|
||||
(queue-callback color-buff))
|
||||
(else
|
||||
(unless (send editor test-froze-colorer?)
|
||||
(send editor freeze-colorer)
|
||||
(send editor toggle-test-status))
|
||||
(send editor begin-test-color)
|
||||
(send editor change-style
|
||||
uncovered-highlight 0
|
||||
(send editor last-position) #f)
|
||||
(let loop ([positions (integer-set-contents int-set)])
|
||||
(unless (null? positions)
|
||||
(send editor change-style covered-highlight
|
||||
(sub1 (caar positions))
|
||||
(sub1 (cdar positions)) #f)
|
||||
(loop (cdr positions))))
|
||||
(send editor end-test-color))))])
|
||||
(queue-callback color-buff))))
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
(define (test-coverage-button-mixin parent)
|
||||
(class* parent ()
|
||||
|
||||
(super-instantiate ())
|
||||
|
||||
(define/public (insert-covered-button dest coverage src src-editor partial?)
|
||||
(let* ((button-editor (new (editor:standard-style-list-mixin text%)
|
||||
[auto-wrap #t]))
|
||||
(snip (new editor-snip% (editor button-editor) (with-border? #t)))
|
||||
(start (send dest get-end-position)))
|
||||
(send snip set-style
|
||||
(send (send dest get-style-list) find-named-style "Standard"))
|
||||
(if partial?
|
||||
(send button-editor insert "Highlight covered expressions")
|
||||
(send button-editor insert "Highlight all covered expressions"))
|
||||
(send dest insert snip)
|
||||
(send button-editor set-clickback
|
||||
0
|
||||
(send button-editor get-end-position)
|
||||
(cond
|
||||
[(and src-editor partial?)
|
||||
(lambda (t s e)
|
||||
(send coverage display-covered-portion src-editor src))]
|
||||
[src-editor
|
||||
(lambda (t s e)
|
||||
(send coverage display-coverage src-editor))]
|
||||
[else (lambda (t s e) (void))])
|
||||
#f #f)
|
||||
(let ((c (new style-delta%)))
|
||||
(send c set-delta-foreground "royalblue")
|
||||
(send dest change-style c start (sub1 (send dest get-end-position)) #f))
|
||||
))
|
||||
)
|
||||
)
|
||||
|
||||
(define analysis<%>
|
||||
(interface ()
|
||||
register-test register-testcase
|
||||
de-register-test de-register-testcase
|
||||
analyze provide-info))
|
||||
|
||||
(define coverage-analysis%
|
||||
(class* object% (analysis<%>)
|
||||
|
||||
(define coverage-info (make-object coverage-track%))
|
||||
|
||||
(define/public (register-test name src)
|
||||
(send coverage-info register-coverage-point src))
|
||||
(define/public (register-testcase name src)
|
||||
(send coverage-info register-coverage-point src))
|
||||
(define/public (de-register-test src)
|
||||
(send coverage-info unregister-coverage-point src))
|
||||
(define/public (de-register-testcase src)
|
||||
(send coverage-info unregister-coverage-point src))
|
||||
(define/public (analyze src vals)
|
||||
(send coverage-info covered-position (list-ref src 3) (list-ref src 4)))
|
||||
|
||||
(define/public (provide-info) coverage-info)
|
||||
(super-instantiate ())
|
||||
))
|
||||
|
||||
|
||||
|
||||
)
|
||||
#lang mzscheme
|
||||
|
||||
(require mzlib/class
|
||||
mred
|
||||
framework
|
||||
(prefix list: mzlib/list)
|
||||
mzlib/integer-set)
|
||||
|
||||
(provide (all-defined))
|
||||
|
||||
(define coverage-track%
|
||||
(class* object% ()
|
||||
|
||||
(super-instantiate ())
|
||||
|
||||
;; interger-set
|
||||
(define covered (make-range))
|
||||
;; [hashtable-of scheme-val -> integer-set]
|
||||
(define covered-from-src (make-hash-table 'weak))
|
||||
;; (listof covered-from-src keys)
|
||||
(define current-coverage-srcs null)
|
||||
|
||||
(define/public (covered-position start span)
|
||||
(let ([new-range (make-range start (+ start span))])
|
||||
(set! covered (union covered new-range))
|
||||
(for-each (lambda (key covered-set)
|
||||
(hash-table-put! covered-from-src key
|
||||
(union covered-set new-range)))
|
||||
current-coverage-srcs
|
||||
(map (lambda (key)
|
||||
(hash-table-get covered-from-src key (make-range)))
|
||||
current-coverage-srcs))))
|
||||
|
||||
(define/public (register-coverage-point src)
|
||||
(set! current-coverage-srcs (cons src current-coverage-srcs)))
|
||||
|
||||
(define/public (unregister-coverage-point src)
|
||||
(set! current-coverage-srcs (list:remq src current-coverage-srcs)))
|
||||
|
||||
(define/public (covers-span? start span)
|
||||
(zero? (card (difference (make-range start (+ start span)) covered))))
|
||||
|
||||
(define/public (covers-spans? srcs)
|
||||
(andmap (lambda (s) (covers-span? (car s) (cdr s))) srcs))
|
||||
|
||||
(define/public (display-coverage editor)
|
||||
(highlight-covered editor covered))
|
||||
|
||||
(define/public (display-covered-portion editor coverage-point)
|
||||
(highlight-covered editor (hash-table-get covered-from-src coverage-point
|
||||
(make-range))))
|
||||
|
||||
|
||||
(define/private (highlight-covered editor int-set)
|
||||
(let* ([style-list (editor:get-standard-style-list)]
|
||||
[uncovered-highlight (send style-list find-named-style
|
||||
"profj:syntax-colors:scheme:uncovered")]
|
||||
[covered-highlight (send style-list find-named-style
|
||||
"profj:syntax-colors:scheme:covered")])
|
||||
(letrec ([color-buff
|
||||
(lambda ()
|
||||
(cond
|
||||
[(or (send editor is-locked?)
|
||||
(send editor in-edit-sequence?))
|
||||
(queue-callback color-buff)]
|
||||
[else
|
||||
(unless (send editor test-froze-colorer?)
|
||||
(send editor freeze-colorer)
|
||||
(send editor toggle-test-status))
|
||||
(send editor begin-test-color)
|
||||
(send editor change-style
|
||||
uncovered-highlight 0
|
||||
(send editor last-position) #f)
|
||||
(let loop ([positions (integer-set-contents int-set)])
|
||||
(unless (null? positions)
|
||||
(send editor change-style covered-highlight
|
||||
(sub1 (caar positions))
|
||||
(sub1 (cdar positions))
|
||||
#f)
|
||||
(loop (cdr positions))))
|
||||
(send editor end-test-color)]))])
|
||||
(queue-callback color-buff))))))
|
||||
|
||||
(define (test-coverage-button-mixin parent)
|
||||
(class* parent ()
|
||||
(super-instantiate ())
|
||||
|
||||
(define/public (insert-covered-button dest coverage src src-editor partial?)
|
||||
(let* ([button-editor (new (editor:standard-style-list-mixin text%)
|
||||
[auto-wrap #t])]
|
||||
[snip (new editor-snip% (editor button-editor) (with-border? #t))]
|
||||
[start (send dest get-end-position)])
|
||||
(send snip set-style
|
||||
(send (send dest get-style-list) find-named-style "Standard"))
|
||||
(send button-editor insert
|
||||
(if partial?
|
||||
"Highlight covered expressions"
|
||||
"Highlight all covered expressions"))
|
||||
(send dest insert snip)
|
||||
(send button-editor set-clickback 0
|
||||
(send button-editor get-end-position)
|
||||
(cond
|
||||
[(and src-editor partial?)
|
||||
(lambda (t s e)
|
||||
(send coverage display-covered-portion src-editor src))]
|
||||
[src-editor
|
||||
(lambda (t s e)
|
||||
(send coverage display-coverage src-editor))]
|
||||
[else (lambda (t s e) (void))])
|
||||
#f #f)
|
||||
(let ([c (new style-delta%)])
|
||||
(send c set-delta-foreground "royalblue")
|
||||
(send dest change-style c start (sub1 (send dest get-end-position))
|
||||
#f))))))
|
||||
|
||||
(define analysis<%>
|
||||
(interface ()
|
||||
register-test register-testcase
|
||||
de-register-test de-register-testcase
|
||||
analyze provide-info))
|
||||
|
||||
(define coverage-analysis%
|
||||
(class* object% (analysis<%>)
|
||||
|
||||
(define coverage-info (make-object coverage-track%))
|
||||
|
||||
(define/public (register-test name src)
|
||||
(send coverage-info register-coverage-point src))
|
||||
(define/public (register-testcase name src)
|
||||
(send coverage-info register-coverage-point src))
|
||||
(define/public (de-register-test src)
|
||||
(send coverage-info unregister-coverage-point src))
|
||||
(define/public (de-register-testcase src)
|
||||
(send coverage-info unregister-coverage-point src))
|
||||
(define/public (analyze src vals)
|
||||
(send coverage-info covered-position (list-ref src 3) (list-ref src 4)))
|
||||
|
||||
(define/public (provide-info) coverage-info)
|
||||
(super-instantiate ())))
|
||||
|
|
|
|||
|
|
@ -1,381 +1,378 @@
|
|||
(module test-display scheme/base
|
||||
|
||||
(require scheme/class
|
||||
scheme/file
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "string-constant.ss" "string-constants"))
|
||||
|
||||
(require "test-info.scm")
|
||||
|
||||
(define test-display%
|
||||
(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 current-tab #f)
|
||||
(define drscheme-frame #f)
|
||||
(define src-editor #f)
|
||||
(define/public (display-settings df ct ed)
|
||||
(set! current-tab ct)
|
||||
(set! drscheme-frame df)
|
||||
(set! src-editor ed))
|
||||
|
||||
(define/public (display-results)
|
||||
(let* ((curr-win (and current-tab (send current-tab get-test-window)))
|
||||
(window (or curr-win (make-object test-window%)))
|
||||
(content (make-object (editor:standard-style-list-mixin text%))))
|
||||
#lang scheme/base
|
||||
|
||||
(send this insert-test-results content test-info src-editor)
|
||||
(send content lock #t)
|
||||
(send window update-editor content)
|
||||
(when current-tab
|
||||
(send current-tab current-test-editor content)
|
||||
(unless curr-win
|
||||
(send current-tab current-test-window window)
|
||||
(send drscheme-frame register-test-window window)
|
||||
(send window update-switch
|
||||
(lambda () (send drscheme-frame dock-tests)))
|
||||
(send window update-disable
|
||||
(lambda () (send current-tab update-test-preference #f)))
|
||||
(send window update-closer
|
||||
(lambda()
|
||||
(send drscheme-frame deregister-test-window window)
|
||||
(send current-tab current-test-window #f)
|
||||
(send current-tab current-test-editor #f)))))
|
||||
(if (and drscheme-frame
|
||||
(get-preference 'profj:test-window:docked?
|
||||
(lambda () (put-preferences '(profj:test-window:docked?) '(#f)) #f)))
|
||||
(send drscheme-frame display-test-panel content)
|
||||
(send window show #t))))
|
||||
|
||||
(define/pubment (insert-test-results editor test-info src-editor)
|
||||
(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)
|
||||
(require scheme/class
|
||||
scheme/file
|
||||
mred
|
||||
framework
|
||||
string-constants
|
||||
"test-info.scm")
|
||||
|
||||
(define test-display%
|
||||
(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 current-tab #f)
|
||||
(define drscheme-frame #f)
|
||||
(define src-editor #f)
|
||||
(define/public (display-settings df ct ed)
|
||||
(set! current-tab ct)
|
||||
(set! drscheme-frame df)
|
||||
(set! src-editor ed))
|
||||
|
||||
(define/public (display-results)
|
||||
(let* ([curr-win (and current-tab (send current-tab get-test-window))]
|
||||
[window (or curr-win (make-object test-window%))]
|
||||
[content (make-object (editor:standard-style-list-mixin text%))])
|
||||
|
||||
(send this insert-test-results content test-info src-editor)
|
||||
(send content lock #t)
|
||||
(send window update-editor content)
|
||||
(when current-tab
|
||||
(send current-tab current-test-editor content)
|
||||
(unless curr-win
|
||||
(send current-tab current-test-window window)
|
||||
(send drscheme-frame register-test-window window)
|
||||
(send window update-switch
|
||||
(lambda () (send drscheme-frame dock-tests)))
|
||||
(send window update-disable
|
||||
(lambda () (send current-tab update-test-preference #f)))
|
||||
(send window update-closer
|
||||
(lambda()
|
||||
(send drscheme-frame deregister-test-window window)
|
||||
(send current-tab current-test-window #f)
|
||||
(send current-tab current-test-editor #f)))))
|
||||
(if (and drscheme-frame
|
||||
(get-preference 'profj:test-window:docked?
|
||||
(lambda ()
|
||||
(put-preferences '(profj:test-window:docked?)
|
||||
'(#f))
|
||||
#f)))
|
||||
(send drscheme-frame display-test-panel content)
|
||||
(send window show #t))))
|
||||
|
||||
(define/pubment (insert-test-results editor test-info src-editor)
|
||||
(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)
|
||||
(send editor insert
|
||||
(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)
|
||||
(send editor insert
|
||||
(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)
|
||||
(send editor insert
|
||||
[(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)
|
||||
(send editor insert
|
||||
(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)
|
||||
(send editor insert
|
||||
(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)
|
||||
editor test-info src-editor)
|
||||
insert-test-results editor test-info src-editor))))
|
||||
|
||||
(define/public (display-check-failures checks editor test-info src-editor)
|
||||
(for ([failed-check (reverse checks)])
|
||||
(send editor insert "\t")
|
||||
(make-link editor
|
||||
(failed-check-msg failed-check)
|
||||
(failed-check-src failed-check)
|
||||
src-editor)
|
||||
(send editor insert "\n")))
|
||||
|
||||
(define/public (next-line editor) (send editor insert "\n\t"))
|
||||
|
||||
;; make-link: text% (listof (U string snip%)) src editor -> void
|
||||
(define (make-link text msg dest src-editor)
|
||||
(for ([m msg])
|
||||
(when (is-a? m snip%)
|
||||
(send m set-style (send (send text get-style-list)
|
||||
find-named-style "Standard")))
|
||||
(send text insert m))
|
||||
(let ((start (send text get-end-position)))
|
||||
(send text insert (format-src dest))
|
||||
(send text set-clickback
|
||||
start (send text get-end-position)
|
||||
(lambda (t s e) (highlight-check-error dest src-editor))
|
||||
#f #f)
|
||||
(let ([end (send text get-end-position)]
|
||||
[c (new style-delta%)])
|
||||
(send text insert " ")
|
||||
(send text change-style
|
||||
(make-object style-delta% 'change-underline #t)
|
||||
start end #f)
|
||||
(send c set-delta-foreground "royalblue")
|
||||
(send text change-style c start end #f))))
|
||||
|
||||
(define (format-src src)
|
||||
(let ([src-file car]
|
||||
[src-line cadr]
|
||||
[src-col caddr])
|
||||
(string-append
|
||||
(cond
|
||||
[(symbol? (src-file src)) (string-append " At ")]
|
||||
[(path? (src-file src)) (string-append " In " (src-file src) " at ")]
|
||||
[(is-a? (src-file src) editor<%>) " At "])
|
||||
"line " (number->string (src-line src))
|
||||
" column " (number->string (src-col src)))))
|
||||
|
||||
(define (highlight-check-error srcloc src-editor)
|
||||
(let* ([src-pos cadddr]
|
||||
[src-span (lambda (l) (car (cddddr l)))]
|
||||
[position (src-pos srcloc)]
|
||||
[span (src-span srcloc)])
|
||||
(when (and current-rep src-editor)
|
||||
(cond
|
||||
[(is-a? src-editor text:basic<%>)
|
||||
(let ((highlight
|
||||
(lambda ()
|
||||
(send current-rep highlight-errors
|
||||
(list (make-srcloc src-editor
|
||||
(cadr srcloc)
|
||||
(caddr srcloc)
|
||||
position span)) #f))))
|
||||
(queue-callback highlight))]))))
|
||||
|
||||
(super-instantiate ())))
|
||||
|
||||
(define test-window%
|
||||
(class* frame% ()
|
||||
|
||||
(super-instantiate
|
||||
((string-constant profj-test-results-window-title) #f 400 350))
|
||||
|
||||
(define editor #f)
|
||||
(define switch-func void)
|
||||
(define disable-func void)
|
||||
(define close-cleanup void)
|
||||
|
||||
(define content
|
||||
(make-object editor-canvas% this #f '(auto-vscroll)))
|
||||
|
||||
(define button-panel
|
||||
(make-object horizontal-panel% this
|
||||
'() #t 0 0 0 0 '(right bottom) 0 0 #t #f))
|
||||
|
||||
(define buttons
|
||||
(list (make-object button%
|
||||
(string-constant close)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(close-cleanup)
|
||||
(send this show #f))))
|
||||
(make-object button%
|
||||
(string-constant profj-test-results-close-and-disable)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(disable-func)
|
||||
(close-cleanup)
|
||||
(send this show #f))))
|
||||
(make-object button%
|
||||
(string-constant dock)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(send this show #f)
|
||||
(put-preferences '(profj:test-window:docked?)
|
||||
'(#t))
|
||||
(switch-func))))
|
||||
(make-object grow-box-spacer-pane% button-panel)))
|
||||
|
||||
(define/public (update-editor e)
|
||||
(set! editor e)
|
||||
(send content set-editor editor))
|
||||
|
||||
(define/public (update-switch thunk)
|
||||
(set! switch-func thunk))
|
||||
(define/public (update-closer thunk)
|
||||
(set! close-cleanup thunk))
|
||||
(define/public (update-disable thunk)
|
||||
(set! disable-func thunk))))
|
||||
|
||||
(define test-panel%
|
||||
(class* vertical-panel% ()
|
||||
|
||||
(inherit get-parent)
|
||||
|
||||
(super-instantiate ())
|
||||
|
||||
(define content (make-object editor-canvas% this #f '()))
|
||||
(define button-panel (make-object horizontal-panel% this
|
||||
'() #t 0 0 0 0 '(right bottom) 0 0 #t #f))
|
||||
(define (hide)
|
||||
(let ([current-tab (send frame get-current-tab)])
|
||||
(send frame deregister-test-window
|
||||
(send current-tab get-test-window))
|
||||
(send current-tab current-test-window #f)
|
||||
(send current-tab current-test-editor #f))
|
||||
(remove))
|
||||
|
||||
(make-object button%
|
||||
(string-constant hide)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(hide))))
|
||||
(make-object button%
|
||||
(string-constant profj-test-results-hide-and-disable)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(hide)
|
||||
(send (send frame get-current-tab)
|
||||
update-test-preference #f))))
|
||||
(make-object button%
|
||||
(string-constant undock)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(put-preferences '(profj:test-window:docked?) '(#f))
|
||||
(send frame undock-tests))))
|
||||
|
||||
(define/public (update-editor e)
|
||||
(send content set-editor e))
|
||||
|
||||
(define frame #f)
|
||||
(define/public (update-frame f)
|
||||
(set! frame f))
|
||||
|
||||
(define/public (remove)
|
||||
(let ([parent (get-parent)])
|
||||
(put-preferences '(profj:test-dock-size)
|
||||
(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"]
|
||||
[(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)
|
||||
(send editor insert
|
||||
[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)
|
||||
(send editor insert
|
||||
(when (> total-checks 0)
|
||||
(printf "~a"
|
||||
(cond
|
||||
[(and (zero? failed-checks) (= 1 total-checks)) "Check passed!\n\n"]
|
||||
[(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)
|
||||
editor test-info src-editor)
|
||||
insert-test-results editor test-info src-editor))
|
||||
))
|
||||
|
||||
(define/public (display-check-failures checks editor test-info src-editor)
|
||||
(for-each
|
||||
(lambda (failed-check)
|
||||
(send editor insert "\t")
|
||||
(make-link editor
|
||||
(failed-check-msg failed-check)
|
||||
(failed-check-src failed-check)
|
||||
src-editor)
|
||||
(send editor insert "\n"))
|
||||
(reverse checks)))
|
||||
|
||||
(define/public (next-line editor) (send editor insert "\n\t"))
|
||||
[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 "")])
|
||||
|
||||
;make-link: text% (listof (U string snip%)) src editor -> void
|
||||
(define (make-link text msg dest src-editor)
|
||||
(for-each (lambda (m)
|
||||
(when (is-a? m snip%)
|
||||
(send m set-style (send (send text get-style-list)
|
||||
find-named-style "Standard")))
|
||||
(send text insert m)) msg)
|
||||
(let ((start (send text get-end-position)))
|
||||
(send text insert (format-src dest))
|
||||
(send text set-clickback
|
||||
start (send text get-end-position)
|
||||
(lambda (t s e)
|
||||
(highlight-check-error dest src-editor))
|
||||
#f #f)
|
||||
(let ((end (send text get-end-position))
|
||||
(c (new style-delta%)))
|
||||
(send text insert " ")
|
||||
(send text change-style (make-object style-delta% 'change-underline #t)
|
||||
start end #f)
|
||||
(send c set-delta-foreground "royalblue")
|
||||
(send text change-style c start end #f))))
|
||||
|
||||
(define (format-src src)
|
||||
(let ([src-file car]
|
||||
[src-line cadr]
|
||||
[src-col caddr])
|
||||
(string-append
|
||||
(cond
|
||||
[(symbol? (src-file src)) (string-append " At ")]
|
||||
((path? (src-file src)) (string-append " In " (src-file src) " at "))
|
||||
((is-a? (src-file src) editor<%>) " At "))
|
||||
"line " (number->string (src-line src))
|
||||
" column " (number->string (src-col src)))))
|
||||
(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 (highlight-check-error srcloc src-editor)
|
||||
(let* ([src-pos cadddr]
|
||||
[src-span (lambda (l) (car (cddddr l)))]
|
||||
[position (src-pos srcloc)]
|
||||
[span (src-span srcloc)])
|
||||
(when (and current-rep src-editor)
|
||||
(cond
|
||||
[(is-a? src-editor text:basic<%>)
|
||||
(let ((highlight
|
||||
(lambda ()
|
||||
(send current-rep highlight-errors
|
||||
(list (make-srcloc src-editor
|
||||
(cadr srcloc)
|
||||
(caddr srcloc)
|
||||
position span)) #f))))
|
||||
(queue-callback highlight))]))))
|
||||
|
||||
(super-instantiate ())))
|
||||
|
||||
(define test-window%
|
||||
(class* frame% ()
|
||||
|
||||
(super-instantiate
|
||||
((string-constant profj-test-results-window-title) #f 400 350))
|
||||
|
||||
(define editor #f)
|
||||
(define switch-func void)
|
||||
(define disable-func void)
|
||||
(define close-cleanup void)
|
||||
|
||||
(define content
|
||||
(make-object editor-canvas% this #f '(auto-vscroll)))
|
||||
|
||||
(define button-panel (make-object horizontal-panel% this
|
||||
'() #t 0 0 0 0 '(right bottom) 0 0 #t #f))
|
||||
|
||||
(define buttons
|
||||
(list (make-object button%
|
||||
(string-constant close)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(close-cleanup)
|
||||
(send this show #f))))
|
||||
(make-object button%
|
||||
(string-constant profj-test-results-close-and-disable)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(disable-func)
|
||||
(close-cleanup)
|
||||
(send this show #f))))
|
||||
(make-object button%
|
||||
(string-constant dock)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(send this show #f)
|
||||
(put-preferences '(profj:test-window:docked?) '(#t))
|
||||
(switch-func))))
|
||||
(make-object grow-box-spacer-pane% button-panel)))
|
||||
|
||||
|
||||
(define/public (update-editor e)
|
||||
(set! editor e)
|
||||
(send content set-editor editor))
|
||||
|
||||
(define/public (update-switch thunk)
|
||||
(set! switch-func thunk))
|
||||
(define/public (update-closer thunk)
|
||||
(set! close-cleanup thunk))
|
||||
(define/public (update-disable thunk)
|
||||
(set! disable-func thunk))
|
||||
))
|
||||
|
||||
(define test-panel%
|
||||
(class* vertical-panel% ()
|
||||
(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")))
|
||||
|
||||
(inherit get-parent)
|
||||
|
||||
(super-instantiate () )
|
||||
(define/public (next-line) (printf "~a" "\n\t"))
|
||||
|
||||
(define content (make-object editor-canvas% this #f '()))
|
||||
(define button-panel (make-object horizontal-panel% this
|
||||
'() #t 0 0 0 0 '(right bottom) 0 0 #t #f))
|
||||
(define (hide)
|
||||
(let ((current-tab (send frame get-current-tab)))
|
||||
(send frame deregister-test-window
|
||||
(send current-tab get-test-window))
|
||||
(send current-tab current-test-window #f)
|
||||
(send current-tab current-test-editor #f))
|
||||
(remove))
|
||||
;; make-link: (listof (U string snip%)) src -> void
|
||||
(define (make-link msg dest)
|
||||
(for-each printf msg)
|
||||
(printf (format-src dest)))
|
||||
|
||||
(make-object button%
|
||||
(string-constant hide)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(hide))))
|
||||
(make-object button%
|
||||
(string-constant profj-test-results-hide-and-disable)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(hide)
|
||||
(send (send frame get-current-tab) update-test-preference #f))))
|
||||
(make-object button%
|
||||
(string-constant undock)
|
||||
button-panel
|
||||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(put-preferences '(profj:test-window:docked?) '(#f))
|
||||
(send frame undock-tests)
|
||||
)))
|
||||
|
||||
(define/public (update-editor e)
|
||||
(send content set-editor e))
|
||||
|
||||
(define frame #f)
|
||||
(define/public (update-frame f)
|
||||
(set! frame f))
|
||||
|
||||
(define/public (remove)
|
||||
(let ((parent (get-parent)))
|
||||
(put-preferences '(profj:test-dock-size) (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-each
|
||||
(lambda (failed-check)
|
||||
(printf "~a" "\t")
|
||||
(make-link (failed-check-msg failed-check)
|
||||
(failed-check-src failed-check)
|
||||
)
|
||||
(printf "~a" "\n"))
|
||||
(reverse checks)))
|
||||
|
||||
(define/public (next-line) (printf "~a" "\n\t"))
|
||||
|
||||
;make-link: (listof (U string snip%)) src -> void
|
||||
(define (make-link msg dest)
|
||||
(for-each (lambda (m) (printf m)) 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)) (string-append " 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)))))
|
||||
(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% test-display-textual%)
|
||||
|
|
|
|||
|
|
@ -1,62 +1,65 @@
|
|||
(module test-engine scheme/base
|
||||
|
||||
(require scheme/class
|
||||
"test-info.scm"
|
||||
"test-display.scm")
|
||||
|
||||
(define test-engine%
|
||||
(class* object% ()
|
||||
(field [test-info #f]
|
||||
[test-display #f])
|
||||
|
||||
(define display-class test-display%)
|
||||
(define display-rep #f)
|
||||
(define display-event-space #f)
|
||||
|
||||
(super-instantiate ())
|
||||
|
||||
(define/public (refine-display-class d) (set! display-class d))
|
||||
(define/public (info-class) test-info-base%)
|
||||
|
||||
(define/public (add-analysis a) (send test-info add-analysis a))
|
||||
|
||||
(define/public (setup-info style)
|
||||
(set! test-info (make-object (send this info-class) style)))
|
||||
(define/pubment (setup-display cur-rep event-space)
|
||||
(set! test-display (make-object display-class cur-rep))
|
||||
(set! display-rep cur-rep)
|
||||
(set! display-event-space event-space)
|
||||
(inner (void) setup-display cur-rep event-space))
|
||||
|
||||
(define/pubment (run)
|
||||
(unless test-info (send this setup-info 'check-base))
|
||||
(inner (void) run))
|
||||
(define/public (summarize-results port)
|
||||
(unless test-display (setup-display #f #f))
|
||||
(let ([result (send test-info summarize-results)])
|
||||
(case result
|
||||
[(no-tests) (send this display-untested port)]
|
||||
[(all-passed) (send this display-success port)]
|
||||
[(mixed-results) (send this display-results display-rep display-event-space)])))
|
||||
|
||||
(define/public (display-success port)
|
||||
(fprintf port "All tests passed!~n"))
|
||||
(define/public (display-untested port)
|
||||
(fprintf port "This program should be tested.~n"))
|
||||
(define/public (display-results rep event-space)
|
||||
(send test-display install-info test-info)
|
||||
(if event-space
|
||||
(parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space])
|
||||
((dynamic-require 'scheme/gui 'queue-callback)
|
||||
(lambda () (send rep display-test-results test-display))))
|
||||
(send test-display display-results)))
|
||||
|
||||
(define/pubment (initialize-test test) (inner (void) initialize-test test))
|
||||
|
||||
(define/pubment (run-test test) (inner (void) run-test test))
|
||||
|
||||
(define/pubment (run-testcase testcase) (inner (void) run-testcase testcase))))
|
||||
|
||||
(provide test-engine%)
|
||||
|
||||
)
|
||||
#lang scheme/base
|
||||
|
||||
(require scheme/class
|
||||
"test-info.scm"
|
||||
"test-display.scm")
|
||||
|
||||
(define test-engine%
|
||||
(class* object% ()
|
||||
(field [test-info #f]
|
||||
[test-display #f])
|
||||
|
||||
(define display-class test-display%)
|
||||
(define display-rep #f)
|
||||
(define display-event-space #f)
|
||||
|
||||
(super-instantiate ())
|
||||
|
||||
(define/public (refine-display-class d) (set! display-class d))
|
||||
(define/public (info-class) test-info-base%)
|
||||
|
||||
(define/public (add-analysis a) (send test-info add-analysis a))
|
||||
|
||||
(define/public (setup-info style)
|
||||
(set! test-info (make-object (send this info-class) style)))
|
||||
(define/pubment (setup-display cur-rep event-space)
|
||||
(set! test-display (make-object display-class cur-rep))
|
||||
(set! display-rep cur-rep)
|
||||
(set! display-event-space event-space)
|
||||
(inner (void) setup-display cur-rep event-space))
|
||||
|
||||
(define/pubment (run)
|
||||
(unless test-info (send this setup-info 'check-base))
|
||||
(inner (void) run))
|
||||
(define/public (summarize-results port)
|
||||
(unless test-display (setup-display #f #f))
|
||||
(let ([result (send test-info summarize-results)])
|
||||
(case result
|
||||
[(no-tests) (send this display-untested port)]
|
||||
[(all-passed) (send this display-success port)]
|
||||
[(mixed-results)
|
||||
(send this display-results display-rep display-event-space)])))
|
||||
|
||||
(define/public (display-success port)
|
||||
(fprintf port "All tests passed!~n"))
|
||||
(define/public (display-untested port)
|
||||
(fprintf port "This program should be tested.~n"))
|
||||
(define/public (display-results rep event-space)
|
||||
(send test-display install-info test-info)
|
||||
(if event-space
|
||||
(parameterize ([(dynamic-require 'scheme/gui 'current-eventspace)
|
||||
event-space])
|
||||
((dynamic-require 'scheme/gui 'queue-callback)
|
||||
(lambda () (send rep display-test-results test-display))))
|
||||
(send test-display display-results)))
|
||||
|
||||
(define/pubment (initialize-test test)
|
||||
(inner (void) initialize-test test))
|
||||
|
||||
(define/pubment (run-test test)
|
||||
(inner (void) run-test test))
|
||||
|
||||
(define/pubment (run-testcase testcase)
|
||||
(inner (void) run-testcase testcase))))
|
||||
|
||||
(provide test-engine%)
|
||||
|
|
|
|||
|
|
@ -1,64 +1,59 @@
|
|||
(module test-info scheme/base
|
||||
|
||||
(require scheme/class)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
;(make-failed-check src (listof (U string snip%)))
|
||||
(define-struct failed-check (src msg))
|
||||
|
||||
(define test-info-base%
|
||||
(class* object% ()
|
||||
|
||||
(super-instantiate ())
|
||||
|
||||
(init-field (style 'check-base))
|
||||
(field [analyses null])
|
||||
|
||||
(define total-tsts 0)
|
||||
(define failed-tsts 0)
|
||||
(define total-cks 0)
|
||||
(define failed-cks 0)
|
||||
|
||||
(define failures null)
|
||||
|
||||
(define/public (test-style) style)
|
||||
(define/public (tests-run) total-tsts)
|
||||
(define/public (tests-failed) failed-tsts)
|
||||
(define/public (checks-run) total-cks)
|
||||
(define/public (checks-failed) failed-cks)
|
||||
(define/public (summarize-results)
|
||||
(cond
|
||||
[(and (zero? total-tsts) (zero? total-cks)) 'no-tests]
|
||||
[(and (zero? failed-cks) (zero? failed-tsts)) 'all-passed]
|
||||
[else 'mixed-results]))
|
||||
|
||||
(define/public (failed-checks) failures)
|
||||
#lang scheme/base
|
||||
|
||||
(define/pubment (add-check)
|
||||
(set! total-cks (add1 total-cks))
|
||||
(inner (void) add-check))
|
||||
|
||||
(define/pubment (add-test)
|
||||
(set! total-tsts (add1 total-tsts))
|
||||
(inner (void) add-test))
|
||||
|
||||
;check-failed: (list (U string snip%)) src -> void
|
||||
(define/pubment (check-failed msg src)
|
||||
(set! failed-cks (add1 failed-cks))
|
||||
(set! failures (cons (make-failed-check src msg) failures))
|
||||
(inner (void) check-failed msg src))
|
||||
|
||||
(define/pubment (test-failed failed-info)
|
||||
(set! failed-tsts (add1 failed-tsts))
|
||||
(inner (void) test-failed failed-info))
|
||||
|
||||
(define/public (add-analysis a) (set! analyses (cons a analyses)))
|
||||
|
||||
(define/public (analyze-position src . vals)
|
||||
(for-each (lambda (a) (send a analyze src vals)) analyses))
|
||||
(define/public (extract-info pred?)
|
||||
(filter pred? (map (lambda (a) (send a provide-info)) analyses)))
|
||||
|
||||
))
|
||||
)
|
||||
(require scheme/class)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; (make-failed-check src (listof (U string snip%)))
|
||||
(define-struct failed-check (src msg))
|
||||
|
||||
(define test-info-base%
|
||||
(class* object% ()
|
||||
(super-instantiate ())
|
||||
|
||||
(init-field (style 'check-base))
|
||||
(field [analyses null])
|
||||
|
||||
(define total-tsts 0)
|
||||
(define failed-tsts 0)
|
||||
(define total-cks 0)
|
||||
(define failed-cks 0)
|
||||
|
||||
(define failures null)
|
||||
|
||||
(define/public (test-style) style)
|
||||
(define/public (tests-run) total-tsts)
|
||||
(define/public (tests-failed) failed-tsts)
|
||||
(define/public (checks-run) total-cks)
|
||||
(define/public (checks-failed) failed-cks)
|
||||
(define/public (summarize-results)
|
||||
(cond [(and (zero? total-tsts) (zero? total-cks)) 'no-tests]
|
||||
[(and (zero? failed-cks) (zero? failed-tsts)) 'all-passed]
|
||||
[else 'mixed-results]))
|
||||
|
||||
(define/public (failed-checks) failures)
|
||||
|
||||
(define/pubment (add-check)
|
||||
(set! total-cks (add1 total-cks))
|
||||
(inner (void) add-check))
|
||||
|
||||
(define/pubment (add-test)
|
||||
(set! total-tsts (add1 total-tsts))
|
||||
(inner (void) add-test))
|
||||
|
||||
;; check-failed: (list (U string snip%)) src -> void
|
||||
(define/pubment (check-failed msg src)
|
||||
(set! failed-cks (add1 failed-cks))
|
||||
(set! failures (cons (make-failed-check src msg) failures))
|
||||
(inner (void) check-failed msg src))
|
||||
|
||||
(define/pubment (test-failed failed-info)
|
||||
(set! failed-tsts (add1 failed-tsts))
|
||||
(inner (void) test-failed failed-info))
|
||||
|
||||
(define/public (add-analysis a) (set! analyses (cons a analyses)))
|
||||
|
||||
(define/public (analyze-position src . vals)
|
||||
(for ([a analyses]) (send a analyze src vals)))
|
||||
(define/public (extract-info pred?)
|
||||
(filter pred? (map (lambda (a) (send a provide-info)) analyses)))))
|
||||
|
|
|
|||
|
|
@ -1,174 +1,169 @@
|
|||
(module test-tool scheme/base
|
||||
|
||||
(require scheme/file scheme/class scheme/unit drscheme/tool framework mred)
|
||||
(require "test-display.scm")
|
||||
(provide tool@)
|
||||
|
||||
(define tool@
|
||||
(unit
|
||||
(import drscheme:tool^)
|
||||
(export drscheme:tool-exports^)
|
||||
(define (phase1) (void))
|
||||
(define (phase2) (void))
|
||||
|
||||
;Overriding interactions as the current-rep implementation
|
||||
(define (test-interactions-text%-mixin %)
|
||||
(class* % ()
|
||||
|
||||
(inherit get-top-level-window get-definitions-text)
|
||||
|
||||
(define/public (display-test-results test-display)
|
||||
(let* ([dr-frame (get-top-level-window)]
|
||||
[ed-def (get-definitions-text)]
|
||||
[tab (and ed-def (send ed-def get-tab))])
|
||||
(when (and dr-frame ed-def tab)
|
||||
(send test-display display-settings dr-frame tab ed-def)
|
||||
(send test-display display-results))))
|
||||
|
||||
(super-instantiate ())
|
||||
)
|
||||
)
|
||||
|
||||
(define (test-definitions-text%-mixin %)
|
||||
(class* % ()
|
||||
(inherit begin-edit-sequence end-edit-sequence)
|
||||
#lang scheme/base
|
||||
|
||||
(define colorer-frozen-by-test? #f)
|
||||
(define/public (test-froze-colorer?) colorer-frozen-by-test?)
|
||||
(define/public (toggle-test-status)
|
||||
(set! colorer-frozen-by-test?
|
||||
(not colorer-frozen-by-test?)))
|
||||
|
||||
(define/public (begin-test-color)
|
||||
(begin-edit-sequence #f))
|
||||
(define/public (end-test-color)
|
||||
(end-edit-sequence))
|
||||
|
||||
(define/augment (on-delete start len)
|
||||
(begin-edit-sequence)
|
||||
(inner (void) on-delete start len))
|
||||
(define/augment (after-delete start len)
|
||||
(inner (void) after-delete start len)
|
||||
(when colorer-frozen-by-test?
|
||||
(send this thaw-colorer)
|
||||
(send this toggle-test-status))
|
||||
(end-edit-sequence))
|
||||
|
||||
(define/augment (on-insert start len)
|
||||
(begin-edit-sequence)
|
||||
(inner (void) on-insert start len))
|
||||
(define/augment (after-insert start len)
|
||||
(inner (void) after-insert start len)
|
||||
(when colorer-frozen-by-test?
|
||||
(send this thaw-colorer)
|
||||
(send this toggle-test-status))
|
||||
(end-edit-sequence))
|
||||
|
||||
(super-instantiate ())))
|
||||
|
||||
(define (test-frame-mixin %)
|
||||
(class* % ()
|
||||
(require scheme/file scheme/class scheme/unit drscheme/tool framework mred)
|
||||
(require "test-display.scm")
|
||||
(provide tool@)
|
||||
|
||||
(inherit get-current-tab)
|
||||
|
||||
(define/public (display-test-panel editor)
|
||||
(send test-panel update-editor editor)
|
||||
(unless (send test-panel is-shown?)
|
||||
(send test-frame add-child test-panel)
|
||||
(let ((test-box-size
|
||||
(get-preference 'profj:test-dock-size (lambda () '(2/3 1/3)))))
|
||||
(send test-frame set-percentages test-box-size))
|
||||
))
|
||||
(define test-panel null)
|
||||
(define test-frame null)
|
||||
|
||||
(define test-windows null)
|
||||
(define/public (register-test-window t)
|
||||
(set! test-windows (cons t test-windows)))
|
||||
(define/public (deregister-test-window t)
|
||||
(set! test-windows (remq t test-windows)))
|
||||
|
||||
(define/public (dock-tests)
|
||||
(for-each (lambda (t) (send t show #f)) test-windows)
|
||||
(let ((ed (send (get-current-tab) get-test-editor)))
|
||||
(when ed (display-test-panel ed))))
|
||||
(define/public (undock-tests)
|
||||
(send test-panel remove)
|
||||
(for-each (lambda (t) (send t show #t)) test-windows))
|
||||
|
||||
(define/override (make-root-area-container cls parent)
|
||||
(let* ([outer-p (super make-root-area-container panel:vertical-dragable% parent)]
|
||||
[louter-panel (make-object vertical-panel% outer-p)]
|
||||
[test-p (make-object test-panel% outer-p '(deleted))]
|
||||
[root (make-object cls louter-panel)])
|
||||
(set! test-panel test-p)
|
||||
(send test-panel update-frame this)
|
||||
(set! test-frame outer-p)
|
||||
root))
|
||||
|
||||
(define/augment (on-tab-change from-tab to-tab)
|
||||
(let ((test-editor (send to-tab get-test-editor))
|
||||
(panel-shown? (send test-panel is-shown?))
|
||||
(dock? (get-preference 'profj:test-window:docked? (lambda () #f))))
|
||||
(cond
|
||||
((and test-editor panel-shown? dock?)
|
||||
(send test-panel update-editor test-editor))
|
||||
((and test-editor dock?)
|
||||
(display-test-panel test-editor))
|
||||
((and panel-shown? (not dock?))
|
||||
(undock-tests))
|
||||
(panel-shown? (send test-panel remove)))
|
||||
(inner (void) on-tab-change from-tab to-tab)))
|
||||
|
||||
(super-instantiate () )))
|
||||
|
||||
(define (test-tab%-mixin %)
|
||||
(class* % ()
|
||||
|
||||
(inherit get-frame get-defs)
|
||||
|
||||
(define test-editor #f)
|
||||
(define/public (get-test-editor) test-editor)
|
||||
(define/public (current-test-editor ed)
|
||||
(set! test-editor ed))
|
||||
|
||||
(define test-window #f)
|
||||
(define/public (get-test-window) test-window)
|
||||
(define/public (current-test-window w) (set! test-window w))
|
||||
|
||||
(define/public (update-test-preference test?)
|
||||
(let* ([language-settings
|
||||
(preferences:get
|
||||
(drscheme:language-configuration:get-settings-preferences-symbol))]
|
||||
[language
|
||||
(drscheme:language-configuration:language-settings-language
|
||||
language-settings)]
|
||||
[settings
|
||||
(drscheme:language-configuration:language-settings-settings
|
||||
language-settings)])
|
||||
(when (object-method-arity-includes? language 'update-test-setting 2)
|
||||
(let ((next-setting (drscheme:language-configuration:make-language-settings
|
||||
language
|
||||
(send language update-test-setting settings test?))))
|
||||
(preferences:set
|
||||
(drscheme:language-configuration:get-settings-preferences-symbol)
|
||||
next-setting)
|
||||
(send (get-defs) set-next-settings next-setting)))))
|
||||
|
||||
(define/augment (on-close)
|
||||
(when test-window
|
||||
(when (send test-window is-shown?)
|
||||
(send test-window show #f))
|
||||
(send (get-frame) deregister-test-window test-window))
|
||||
(inner (void) on-close))
|
||||
|
||||
(super-instantiate () )))
|
||||
|
||||
(drscheme:get/extend:extend-definitions-text test-definitions-text%-mixin)
|
||||
(drscheme:get/extend:extend-interactions-text test-interactions-text%-mixin)
|
||||
(drscheme:get/extend:extend-unit-frame test-frame-mixin)
|
||||
(drscheme:get/extend:extend-tab test-tab%-mixin)
|
||||
|
||||
))
|
||||
(define tool@
|
||||
(unit (import drscheme:tool^) (export drscheme:tool-exports^)
|
||||
|
||||
)
|
||||
(define (phase1) (void))
|
||||
(define (phase2) (void))
|
||||
|
||||
;; Overriding interactions as the current-rep implementation
|
||||
(define (test-interactions-text%-mixin %)
|
||||
(class* % ()
|
||||
(inherit get-top-level-window get-definitions-text)
|
||||
|
||||
(define/public (display-test-results test-display)
|
||||
(let* ([dr-frame (get-top-level-window)]
|
||||
[ed-def (get-definitions-text)]
|
||||
[tab (and ed-def (send ed-def get-tab))])
|
||||
(when (and dr-frame ed-def tab)
|
||||
(send test-display display-settings dr-frame tab ed-def)
|
||||
(send test-display display-results))))
|
||||
|
||||
(super-instantiate ())))
|
||||
|
||||
(define (test-definitions-text%-mixin %)
|
||||
(class* % ()
|
||||
(inherit begin-edit-sequence end-edit-sequence)
|
||||
|
||||
(define colorer-frozen-by-test? #f)
|
||||
(define/public (test-froze-colorer?) colorer-frozen-by-test?)
|
||||
(define/public (toggle-test-status)
|
||||
(set! colorer-frozen-by-test?
|
||||
(not colorer-frozen-by-test?)))
|
||||
|
||||
(define/public (begin-test-color)
|
||||
(begin-edit-sequence #f))
|
||||
(define/public (end-test-color)
|
||||
(end-edit-sequence))
|
||||
|
||||
(define/augment (on-delete start len)
|
||||
(begin-edit-sequence)
|
||||
(inner (void) on-delete start len))
|
||||
(define/augment (after-delete start len)
|
||||
(inner (void) after-delete start len)
|
||||
(when colorer-frozen-by-test?
|
||||
(send this thaw-colorer)
|
||||
(send this toggle-test-status))
|
||||
(end-edit-sequence))
|
||||
|
||||
(define/augment (on-insert start len)
|
||||
(begin-edit-sequence)
|
||||
(inner (void) on-insert start len))
|
||||
(define/augment (after-insert start len)
|
||||
(inner (void) after-insert start len)
|
||||
(when colorer-frozen-by-test?
|
||||
(send this thaw-colorer)
|
||||
(send this toggle-test-status))
|
||||
(end-edit-sequence))
|
||||
|
||||
(super-instantiate ())))
|
||||
|
||||
(define (test-frame-mixin %)
|
||||
(class* % ()
|
||||
(inherit get-current-tab)
|
||||
|
||||
(define/public (display-test-panel editor)
|
||||
(send test-panel update-editor editor)
|
||||
(unless (send test-panel is-shown?)
|
||||
(send test-frame add-child test-panel)
|
||||
(let ([test-box-size
|
||||
(get-preference 'profj:test-dock-size
|
||||
(lambda () '(2/3 1/3)))])
|
||||
(send test-frame set-percentages test-box-size))))
|
||||
(define test-panel null)
|
||||
(define test-frame null)
|
||||
|
||||
(define test-windows null)
|
||||
(define/public (register-test-window t)
|
||||
(set! test-windows (cons t test-windows)))
|
||||
(define/public (deregister-test-window t)
|
||||
(set! test-windows (remq t test-windows)))
|
||||
|
||||
(define/public (dock-tests)
|
||||
(for ([t test-windows]) (send t show #f))
|
||||
(let ([ed (send (get-current-tab) get-test-editor)])
|
||||
(when ed (display-test-panel ed))))
|
||||
(define/public (undock-tests)
|
||||
(send test-panel remove)
|
||||
(for ([t test-windows]) (send t show #t)))
|
||||
|
||||
(define/override (make-root-area-container cls parent)
|
||||
(let* ([outer-p (super make-root-area-container
|
||||
panel:vertical-dragable% parent)]
|
||||
[louter-panel (make-object vertical-panel% outer-p)]
|
||||
[test-p (make-object test-panel% outer-p '(deleted))]
|
||||
[root (make-object cls louter-panel)])
|
||||
(set! test-panel test-p)
|
||||
(send test-panel update-frame this)
|
||||
(set! test-frame outer-p)
|
||||
root))
|
||||
|
||||
(define/augment (on-tab-change from-tab to-tab)
|
||||
(let ([test-editor (send to-tab get-test-editor)]
|
||||
[panel-shown? (send test-panel is-shown?)]
|
||||
[dock? (get-preference 'profj:test-window:docked?
|
||||
(lambda () #f))])
|
||||
(cond [(and test-editor panel-shown? dock?)
|
||||
(send test-panel update-editor test-editor)]
|
||||
[(and test-editor dock?)
|
||||
(display-test-panel test-editor)]
|
||||
[(and panel-shown? (not dock?))
|
||||
(undock-tests)]
|
||||
[panel-shown? (send test-panel remove)])
|
||||
(inner (void) on-tab-change from-tab to-tab)))
|
||||
|
||||
(super-instantiate ())))
|
||||
|
||||
(define (test-tab%-mixin %)
|
||||
(class* % ()
|
||||
(inherit get-frame get-defs)
|
||||
|
||||
(define test-editor #f)
|
||||
(define/public (get-test-editor) test-editor)
|
||||
(define/public (current-test-editor ed)
|
||||
(set! test-editor ed))
|
||||
|
||||
(define test-window #f)
|
||||
(define/public (get-test-window) test-window)
|
||||
(define/public (current-test-window w) (set! test-window w))
|
||||
|
||||
(define/public (update-test-preference test?)
|
||||
(let* ([language-settings
|
||||
(preferences:get
|
||||
(drscheme:language-configuration:get-settings-preferences-symbol))]
|
||||
[language
|
||||
(drscheme:language-configuration:language-settings-language
|
||||
language-settings)]
|
||||
[settings
|
||||
(drscheme:language-configuration:language-settings-settings
|
||||
language-settings)])
|
||||
(when (object-method-arity-includes? language
|
||||
'update-test-setting 2)
|
||||
(let ([next-setting
|
||||
(drscheme:language-configuration:make-language-settings
|
||||
language
|
||||
(send language update-test-setting settings test?))])
|
||||
(preferences:set
|
||||
(drscheme:language-configuration:get-settings-preferences-symbol)
|
||||
next-setting)
|
||||
(send (get-defs) set-next-settings next-setting)))))
|
||||
|
||||
(define/augment (on-close)
|
||||
(when test-window
|
||||
(when (send test-window is-shown?)
|
||||
(send test-window show #f))
|
||||
(send (get-frame) deregister-test-window test-window))
|
||||
(inner (void) on-close))
|
||||
|
||||
(super-instantiate ())))
|
||||
|
||||
(drscheme:get/extend:extend-definitions-text test-definitions-text%-mixin)
|
||||
(drscheme:get/extend:extend-interactions-text test-interactions-text%-mixin)
|
||||
(drscheme:get/extend:extend-unit-frame test-frame-mixin)
|
||||
(drscheme:get/extend:extend-tab test-tab%-mixin)
|
||||
|
||||
))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user