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

formatting, v4-isms, props, etc

Browse Source 
svn: r9168
This commit is contained in:
Eli Barzilay 2008-04-05 16:10:01 +00:00
parent a3d8cb9447
commit 22f506d718
9 changed files with 1439 additions and 1448 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/test-engine/info.ss
View File

@ -1,5 +1,4 @@
(module info setup/infotab #lang setup/infotab
(define name "Test Engine")
(define tools (list (list "test-tool.scm"))) (define tools (list (list "test-tool.scm")))
(define tool-names '("Test Engine")) (define tool-names '("Test Engine"))
)

227
collects/test-engine/java-tests.scm
View File

@ -1,14 +1,14 @@
(module java-tests scheme/base #lang scheme/base
(require scheme/class (require scheme/class
(lib "etc.ss") mzlib/etc
(lib "display-java.ss" "profj")) profj/display-java
(require "test-engine.scm" "test-engine.scm"
"test-display.scm" "test-display.scm"
"test-info.scm" "test-info.scm"
"test-coverage.scm") "test-coverage.scm")
(define (java-test-maker test-info-class style) (define (java-test-maker test-info-class style)
(class* test-engine% () (class* test-engine% ()
(inherit initialize-test run-test) (inherit initialize-test run-test)
@ -29,13 +29,11 @@
(define/public (test-objects) test-objs) (define/public (test-objects) test-objs)
(define/augment (run) (define/augment (run)
(for-each (lambda (t) (initialize-test t)) tests) (for ([t tests]) (initialize-test t))
(inner (void) run) (inner (void) run)
(for-each (lambda (t) (run-test t)) tests)) (for ([t tests]) (run-test t)))))
)) (define (java-test test-info-class)
(define (java-test test-info-class)
(class* (java-test-maker test-info-class 'test-basic) () (class* (java-test-maker test-info-class 'test-basic) ()
(super-instantiate ()) (super-instantiate ())
@ -45,26 +43,25 @@
(let ([test-name (car test)] (let ([test-name (car test)]
[test-class (cadr test)] [test-class (cadr test)]
[test-src (caddr test)]) [test-src (caddr test)])
(send test-info add-test-class test-name test-src) ;need to run constructor ;; need to run constructor
(send test-info add-test-class test-name test-src)
(let ([test-obj (make-object test-class)]) (let ([test-obj (make-object test-class)])
(set! test-objs (cons test-obj test-objs)) (set! test-objs (cons test-obj test-objs))
(for-each (lambda (tc) (run-testcase tc)) (for ([tc (send test-obj testMethods)]) (run-testcase tc))
(send test-obj testMethods))
(let ([tested-classes (send test-obj testedClasses)]) (let ([tested-classes (send test-obj testedClasses)])
(send test-info add-tests-info tested-classes (send test-info add-tests-info tested-classes
(map (lambda (c) (send test-obj testedMethods c)) tested-classes) (map (lambda (c) (send test-obj testedMethods c))
(map (lambda (c) (send test-obj testedMethodsSrcs c)) tested-classes)))) tested-classes)
(map (lambda (c) (send test-obj testedMethodsSrcs c))
tested-classes))))
(send test-info complete-test))) (send test-info complete-test)))
(define/augride (run-testcase tc) (define/augride (run-testcase tc)
(send test-info add-testcase (car tc) (car tc)) (send test-info add-testcase (car tc) (car tc))
;put this in a with-handlers ;; put this in a with-handlers
(let ([res ((cadr tc))]) (let ([res ((cadr tc))]) (send test-info complete-testcase res)))))
(send test-info complete-testcase res)))
)) (define (java-examples test-info-class)
(define (java-examples test-info-class)
(class* (java-test-maker test-info-class 'test-basic) () (class* (java-test-maker test-info-class 'test-basic) ()
(super-instantiate ()) (super-instantiate ())
@ -79,24 +76,24 @@
(set! test-objs (cons test-obj test-objs)) (set! test-objs (cons test-obj test-objs))
(with-handlers ((exn? (lambda (e) (raise e)))) (with-handlers ((exn? (lambda (e) (raise e))))
((current-eval) ((current-eval)
#`(send #,test-obj #,(string->symbol (string-append test-name "-constructor"))))) #`(send #,test-obj
(for-each (lambda (tc) (run-testcase tc)) #,(string->symbol (string-append test-name
(build-testcases test-obj)) "-constructor")))))
(for ([tc (build-testcases test-obj)]) (run-testcase tc))
(send test-info complete-test)))) (send test-info complete-test))))
(define/private (build-testcases object) (define/private (build-testcases object)
(let ([methods (reverse (interface->method-names (object-interface object)))]) (let ([methods (reverse (interface->method-names
(map (lambda (m) (list m (object-interface object)))])
(lambda () ((current-eval) #`(send #,object #,m))) (map (lambda (m)
#f)) (list m (lambda () ((current-eval) #`(send #,object #,m))) #f))
methods))) methods)))
(define/augride (run-testcase tc) (define/augride (run-testcase tc)
(cond (cond [(test-method? (car tc))
[(test-method? (car tc))
(send test-info add-testcase (car tc) (car tc)) (send test-info add-testcase (car tc) (car tc))
(let ([res ((cadr tc))]) (let ([res ((cadr tc))])
(send test-info complete-testcase res))] ;insert with-handlers (send test-info complete-testcase res))] ; insert with-handlers
[(test-method-name? (car tc)) [(test-method-name? (car tc))
(send test-info add-malformed-test (car tc))] (send test-info add-malformed-test (car tc))]
[(close-to-test-name? (car tc)) [(close-to-test-name? (car tc))
@ -107,26 +104,20 @@
(and (test-method-name? name) (no-args? name))) (and (test-method-name? name) (no-args? name)))
(define (test-method-name? name) (define (test-method-name? name)
(regexp-match "^test" (symbol->string name))) (regexp-match? #rx"^test" (symbol->string name)))
(define (no-args? name) (define (no-args? name)
(not (regexp-match "-" (symbol->string name)))) (not (regexp-match? #rx"-" (symbol->string name))))
(define (close-to-test-name? name) (define (close-to-test-name? name)
(let ((n (symbol->string name))) (let ([n (symbol->string name)])
(or (regexp-match "^tst" n) (regexp-match? "^(?:tst|tet|Test|tes)" 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%
(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% () (class* test-info-base% ()
(inherit add-test test-failed) (inherit add-test test-failed)
@ -141,7 +132,8 @@
(define/public (add-tests-info tests test-methods test-method-srcs) (define/public (add-tests-info tests test-methods test-method-srcs)
(set-test-stat-tests! current-test (set-test-stat-tests! current-test
(map make-tests-data tests test-methods test-method-srcs))) (map make-tests-data
tests test-methods test-method-srcs)))
(define/pubment (complete-test) (define/pubment (complete-test)
(set! test-class-stats (cons current-test test-class-stats)) (set! test-class-stats (cons current-test test-class-stats))
@ -166,49 +158,52 @@
(when current-testcase (when current-testcase
(set-testcase-stat-checks! (set-testcase-stat-checks!
current-testcase current-testcase
(cons (make-failed-check src msg) (testcase-stat-checks current-testcase)))) (cons (make-failed-check src msg)
(testcase-stat-checks current-testcase))))
(inner (void) check-failed msg src)) (inner (void) check-failed msg src))
(define/public (format-value value) (define/public (format-value value)
(make-java-snip value (make-format-style #t 'field #f))) (make-java-snip value (make-format-style #t 'field #f)))
(super-instantiate ()) (super-instantiate ())))
)) (define java-examples-info%
(define java-examples-info%
(class* java-test-info% () (class* java-test-info% ()
(define nearly-tests null) (define nearly-tests null)
(define nearly-testcases null) (define nearly-testcases null)
(define/public (add-nearly-test name) (set! nearly-tests (cons name nearly-tests))) (define/public (add-nearly-test name)
(define/public (add-nearly-testcase name) (set! nearly-testcases (cons name nearly-testcases))) (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-tests) nearly-tests)
(define/public (close-testcases) nearly-testcases) (define/public (close-testcases) nearly-testcases)
(super-instantiate ()))) (super-instantiate ())))
(define (analyzed-test-mixin% test-info-parent) (define (analyzed-test-mixin% test-info-parent)
(class* test-info-parent () (class* test-info-parent ()
(inherit get-current-test get-current-testcase) (inherit get-current-test get-current-testcase)
(inherit-field analyses) (inherit-field analyses)
(define/augment (add-test-class name src) (define/augment (add-test-class name src)
(for-each (lambda (a) (send a register-test name src)) analyses) (for ([a analyses]) (send a register-test name src))
(inner (void) add-test-class name src)) (inner (void) add-test-class name src))
(define/augment (complete-test) (define/augment (complete-test)
(for-each (lambda (a) (send a de-register-test (test-stat-src (get-current-test)))) analyses) (for ([a analyses])
(send a de-register-test (test-stat-src (get-current-test))))
(inner (void) complete-test)) (inner (void) complete-test))
(define/augment (add-testcase name src) (define/augment (add-testcase name src)
(for-each (lambda (a) (send a register-testcase name src)) analyses) (for ([a analyses]) (send a register-testcase name src))
(inner (void) add-testcase name src)) (inner (void) add-testcase name src))
(define/augment (complete-testcase pass?) (define/augment (complete-testcase pass?)
(for-each (lambda (a) (send a de-register-testcase (testcase-stat-src (get-current-testcase)))) analyses) (for ([a analyses])
(send a de-register-testcase (testcase-stat-src (get-current-testcase))))
(inner (void) complete-testcase pass?)) (inner (void) complete-testcase pass?))
(super-instantiate ()))) (super-instantiate ())))
(define java-test-display% (define java-test-display%
(class* test-display% () (class* test-display% ()
(super-instantiate ()) (super-instantiate ())
@ -225,51 +220,48 @@
(define/pubment (insert-testcase-name editor testcase-stat src-editor) (define/pubment (insert-testcase-name editor testcase-stat src-editor)
(send editor insert (format "~a ~a" (send editor insert (format "~a ~a"
(testcase-stat-name testcase-stat) (testcase-stat-name testcase-stat)
(if (testcase-stat-pass? testcase-stat) "succeeded!" "failed"))) (if (testcase-stat-pass? testcase-stat)
"succeeded!" "failed")))
(inner (void) insert-testcase-name editor testcase-stat src-editor) (inner (void) insert-testcase-name editor testcase-stat src-editor)
(next-line editor)) (next-line editor))
(define/augment (insert-test-results editor test-info src-editor) (define/augment (insert-test-results editor test-info src-editor)
(inner (void) 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) (insert-tests editor test-info src-editor))
)
(define/pubment (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))) (send editor insert
(for-each (format "Ran the following ~a:\n" (send this test-name)))
(lambda (test) (for ([test (send test-info get-test-results)])
(send editor insert "\n") (send editor insert "\n")
(send this insert-test-name editor test src-editor) (send this insert-test-name editor test src-editor)
(unless (null? (test-stat-cases test)) (unless (null? (test-stat-cases test))
(let* ([run-tests (reverse (test-stat-cases test))] (let* ([run-tests (reverse (test-stat-cases test))]
[num-tests (length run-tests)] [num-tests (length run-tests)]
[failed-tests (filter (compose not testcase-stat-pass?) run-tests)]) [failed-tests (filter (compose not testcase-stat-pass?)
run-tests)])
(next-line editor) (next-line editor)
(send editor insert (format "Ran ~a ~a." num-tests (send this testcase-name))) (send editor insert
(format "Ran ~a ~a." num-tests (send this testcase-name)))
(next-line editor) (next-line editor)
(send editor insert
(if (null? failed-tests) (if (null? failed-tests)
(send editor insert (format "All ~a passed!" (send this testcase-name))) (format "All ~a passed!" (send this testcase-name))
(send editor insert (format "~a of ~a ~a failed:" (format "~a of ~a ~a failed:"
(length failed-tests) num-tests (length failed-tests) num-tests
(send this testcase-name)))) (send this testcase-name))))
(next-line editor) (next-line editor)
(for-each (for ([testcase run-tests])
(lambda (testcase)
(send this insert-testcase-name editor testcase src-editor) (send this insert-testcase-name editor testcase src-editor)
(cond (if (null? (testcase-stat-checks testcase))
[(null? (testcase-stat-checks testcase)) (send editor insert "All checks succeeded!\n")
(send editor insert "All checks succeeded!\n")] (send this display-check-failures
[else (testcase-stat-checks testcase)
(send this display-check-failures (testcase-stat-checks testcase) editor test-info src-editor))
editor test-info src-editor)])
(next-line editor)) (next-line editor))
run-tests) (inner (void) insert-tests editor test-info src-editor)))))))
(inner (void) insert-tests editor test-info src-editor))))
(send test-info get-test-results)
))
))
(define java-examples-display% (define java-examples-display%
(class* java-test-display% () (class* java-test-display% ()
(super-instantiate ()) (super-instantiate ())
@ -280,12 +272,11 @@
(unless (null? (send test-info close-tests)) (unless (null? (send test-info close-tests))
(send editor insert "\n") (send editor insert "\n")
(send editor insert "The following classes were not run, but are similar to example classes:\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))) (for ([name (send test-info close-tests)])
(send test-info close-tests))) (send editor insert (format "\t~a\n" name))))
(inner (void) insert-tests editor test-info src-editor)) (inner (void) insert-tests editor test-info src-editor))))
))
(define (java-coverage-display-mixin parent) (define (java-coverage-display-mixin parent)
(class* parent () (class* parent ()
(field (coverage-info #f)) (field (coverage-info #f))
@ -302,20 +293,21 @@
(inner (void) insert-test-results editor test-info src-editor)) (inner (void) insert-test-results editor test-info src-editor))
(define/augment (insert-test-name editor test-stat 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) (insert-covered-button editor coverage-info (test-stat-src test-stat)
src-editor #t)
(send editor insert "\n") (send editor insert "\n")
(for-each (for ([tested (test-stat-tests test-stat)])
(lambda (tested) (unless (send coverage-info covers-spans
(unless (send coverage-info covers-spans (tests-data-method-srcs tested)) (tests-data-method-srcs tested))
(send editor insert (format-uncovered-message (test-stat-name test-stat) (send editor insert
(format-uncovered-message (test-stat-name test-stat)
(tests-data-c-name tested))) (tests-data-c-name tested)))
(for-each (lambda (sub sub-span) (for ([sub (tests-data-methods tested)]
[sub-span (tests-data-method-srcs tested)])
(send editor insert
(if (send coverage-info covers-span sub-span) (if (send coverage-info covers-span sub-span)
(send editor insert (format-covered-sub sub)) (format-covered-sub sub)
(send editor insert (format-uncovered-sub sub)))) (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)) (inner (void) insert-test-name editor test-stat src-editor))
(define (format-uncovered-message test tests) (define (format-uncovered-message test tests)
@ -327,23 +319,28 @@
(define/augride (insert-testcase-name editor testcase-stat src-editor) (define/augride (insert-testcase-name editor testcase-stat src-editor)
(insert-covered-button editor coverage-info (testcase-stat-src testcase-stat) src-editor #t)) (insert-covered-button editor coverage-info
(testcase-stat-src testcase-stat)
src-editor #t))
(super-instantiate ()))) (super-instantiate ())))
(define java-test-base% (java-test (analyzed-test-mixin% java-test-info%))) (define java-test-base% (java-test (analyzed-test-mixin% java-test-info%)))
(define java-test-graphics% java-test-display%) (define java-test-graphics% java-test-display%)
(define java-test-coverage-graphics% (java-coverage-display-mixin (define java-test-coverage-graphics%
(test-coverage-button-mixin (java-coverage-display-mixin
java-test-display%))) (test-coverage-button-mixin java-test-display%)))
(define java-examples-engine% (java-examples (analyzed-test-mixin% java-examples-info%))) (define java-examples-engine%
(define java-examples-graphics% java-examples-display%) (java-examples (analyzed-test-mixin% java-examples-info%)))
(define java-examples-coverage-graphics% (java-coverage-display-mixin (define java-examples-graphics% java-examples-display%)
(test-coverage-button-mixin (define java-examples-coverage-graphics%
java-examples-display%))) (java-coverage-display-mixin
(test-coverage-button-mixin java-examples-display%)))
(provide java-test-base% java-test-graphics% java-test-coverage-graphics% (provide java-test-base%
java-examples-engine% java-examples-graphics% java-examples-coverage-graphics%) java-test-graphics%
java-test-coverage-graphics%
) java-examples-engine%
java-examples-graphics%
java-examples-coverage-graphics%)

23
collects/test-engine/scheme-gui.scm
View File

@ -1,13 +1,12 @@
(module scheme-gui scheme/base #lang scheme/base
(require scheme/class) (require scheme/class
(require "test-engine.scm") "test-engine.scm")
(define scheme-test-data (make-parameter (list #f #f))) (define scheme-test-data (make-parameter (list #f #f)))
(define scheme-test% (define scheme-test%
(class* test-engine% () (class* test-engine% ()
(super-instantiate ()) (super-instantiate ())
(inherit-field test-info test-display) (inherit-field test-info test-display)
(inherit setup-info) (inherit setup-info)
@ -23,12 +22,10 @@
(define/augment (run) (define/augment (run)
(inner (void) run) (inner (void) run)
(for-each (lambda (t) (run-test t)) (reverse tests))) (for ([t (reverse tests)]) (run-test t)))
(define/augment (run-test test) (test) (define/augment (run-test test)
(inner (void) run-test test)) (test)
(inner (void) run-test test))))
)) (provide scheme-test% scheme-test-data)
(provide scheme-test% scheme-test-data)
)

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

@ -1,119 +1,120 @@
(module scheme-tests mzscheme #lang mzscheme
(require (lib "teachprims.ss" "lang" "private") (require lang/private/teachprims
mred mred
framework framework
mzlib/pretty mzlib/pretty
mzlib/pconvert mzlib/pconvert
mzlib/class) mzlib/class
"scheme-gui.scm"
(require "scheme-gui.scm"
"test-display.scm") "test-display.scm")
(require-for-syntax (lib "shared.ss" "stepper" "private")) (require-for-syntax stepper/private/shared)
(provide (provide
check-expect ;; syntax : (check-expect <expression> <expression>) check-expect ;; syntax : (check-expect <expression> <expression>)
check-within ;; syntax : (check-within <expression> <expression> <expression>) check-within ;; syntax : (check-within <expression> <expression> <expression>)
check-error ;; syntax : (check-error <expression> <expression>) check-error ;; syntax : (check-error <expression> <expression>)
) )
(define builder (define (builder)
(lambda ()
(let ([te (build-test-engine)]) (let ([te (build-test-engine)])
(namespace-set-variable-value! 'test~object te (current-namespace)) (namespace-set-variable-value! 'test~object te (current-namespace))
te))) te))
(define (test) (define (test)
(run-tests) (run-tests)
(display-results)) (display-results))
(define (test-text) (define (test-text)
(run-tests) (run-tests)
(print-results)) (print-results))
(define-syntax (run-tests stx) (define-syntax (run-tests stx)
(syntax-case stx () (syntax-case stx ()
((_) [(_)
(syntax-property (syntax-property
#'(run (namespace-variable-value 'test~object #f builder (current-namespace))) #'(run (namespace-variable-value 'test~object #f builder
'test-call #t)))) (current-namespace)))
'test-call #t)]))
(define (run test-info) (and test-info (send test-info run))) (define (run test-info) (and test-info (send test-info run)))
(define-syntax (display-results stx) (define-syntax (display-results stx)
(syntax-case stx () (syntax-case stx ()
((_) [(_)
(syntax-property (syntax-property
#'(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))]) #'(let ([test-info (namespace-variable-value 'test~object #f builder
(current-namespace))])
(and test-info (and test-info
(let ([display-data (scheme-test-data)]) (let ([display-data (scheme-test-data)])
(send test-info setup-display (car display-data) (cadr display-data)) (send test-info setup-display
(car display-data) (cadr display-data))
(send test-info summarize-results (current-output-port))))) (send test-info summarize-results (current-output-port)))))
'test-call #t)))) 'test-call #t)]))
(define-syntax (print-results stx) (define-syntax (print-results stx)
(syntax-case stx () (syntax-case stx ()
((_) [(_)
(syntax-property (syntax-property
#'(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))]) #'(let ([test-info (namespace-variable-value 'test~object #f builder
(current-namespace))])
(and test-info (and test-info
(send test-info refine-display-class test-display-textual%) (send test-info refine-display-class test-display-textual%)
(send test-info summarize-results (current-output-port)))) (send test-info summarize-results (current-output-port))))
'test-call #t)))) 'test-call #t)]))
(provide run-tests display-results test test-text)
(provide run-tests display-results test test-text) (define (build-test-engine)
(define (build-test-engine)
(let ([engine (make-object scheme-test%)]) (let ([engine (make-object scheme-test%)])
(send engine setup-info 'check-require) (send engine setup-info 'check-require)
engine)) engine))
(define (insert-test test-info test) (send test-info add-test test)) (define (insert-test test-info test) (send test-info add-test test))
(define INEXACT-NUMBERS-FMT (define INEXACT-NUMBERS-FMT
"check-expect cannot compare inexact numbers. Try (check-within test ~a range).") "check-expect cannot compare inexact numbers. Try (check-within test ~a range).")
(define CHECK-ERROR-STR-FMT (define CHECK-ERROR-STR-FMT
"check-error requires a string for the second argument, representing the expected error message. Given ~s") "check-error requires a string for the second argument, representing the expected error message. Given ~s")
(define CHECK-WITHIN-INEXACT-FMT (define CHECK-WITHIN-INEXACT-FMT
"check-within requires an inexact number for the range. ~a is not inexact.") "check-within requires an inexact number for the range. ~a is not inexact.")
(define-for-syntax CHECK-EXPECT-STR (define-for-syntax CHECK-EXPECT-STR
"check-expect requires two expressions. Try (check-expect test expected).") "check-expect requires two expressions. Try (check-expect test expected).")
(define-for-syntax CHECK-ERROR-STR (define-for-syntax CHECK-ERROR-STR
"check-error requires two expressions. Try (check-error test message).") "check-error requires two expressions. Try (check-error test message).")
(define-for-syntax CHECK-WITHIN-STR (define-for-syntax CHECK-WITHIN-STR
"check-within requires three expressions. Try (check-within test expected range).") "check-within requires three expressions. Try (check-within test expected range).")
(define-for-syntax CHECK-EXPECT-DEFN-STR (define-for-syntax CHECK-EXPECT-DEFN-STR
"check-expect cannot be used as an expression") "check-expect cannot be used as an expression")
(define-for-syntax CHECK-WITHIN-DEFN-STR (define-for-syntax CHECK-WITHIN-DEFN-STR
"check-within cannot be used as an expression") "check-within cannot be used as an expression")
(define-for-syntax CHECK-ERROR-DEFN-STR (define-for-syntax CHECK-ERROR-DEFN-STR
"check-error cannot be used as an expression") "check-error cannot be used as an expression")
(define-struct check-fail (src)) (define-struct check-fail (src))
;(make-unexpected-error src string) ;; (make-unexpected-error src string)
(define-struct (unexpected-error check-fail) (expected message)) (define-struct (unexpected-error check-fail) (expected message))
;(make-unequal src scheme-val scheme-val) ;; (make-unequal src scheme-val scheme-val)
(define-struct (unequal check-fail) (test actual)) (define-struct (unequal check-fail) (test actual))
;(make-outofrange src scheme-val scheme-val inexact) ;; (make-outofrange src scheme-val scheme-val inexact)
(define-struct (outofrange check-fail) (test actual range)) (define-struct (outofrange check-fail) (test actual range))
;(make-incorrect-error src string) ;; (make-incorrect-error src string)
(define-struct (incorrect-error check-fail) (expected message)) (define-struct (incorrect-error check-fail) (expected message))
;(make-expected-error src string scheme-val) ;; (make-expected-error src string scheme-val)
(define-struct (expected-error check-fail) (message value)) (define-struct (expected-error check-fail) (message value))
(define-syntax (check-expect stx) (define-syntax (check-expect stx)
(syntax-case stx () (syntax-case stx ()
((_ test actual) [(_ test actual)
(not (eq? (syntax-local-context) 'expression)) (not (eq? (syntax-local-context) 'expression))
(quasisyntax/loc stx (quasisyntax/loc stx
(define #,(gensym 'test) (define #,(gensym 'test)
#,(stepper-syntax-property #,(stepper-syntax-property
#`(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))]) #`(let ([test-info (namespace-variable-value
'test~object #f builder (current-namespace))])
(when test-info (when test-info
(insert-test test-info (insert-test test-info
(lambda () (lambda ()
@ -127,19 +128,19 @@
(syntax-span stx))) (syntax-span stx)))
test-info))))) test-info)))))
`stepper-hint `stepper-hint
`comes-from-check-expect)))) `comes-from-check-expect)))]
((_ test) [(_ test)
(not (eq? (syntax-local-context) 'expression)) (not (eq? (syntax-local-context) 'expression))
(raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)) (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)]
((_ test actual extra ...) [(_ test actual extra ...)
(not (eq? (syntax-local-context) 'expression)) (not (eq? (syntax-local-context) 'expression))
(raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)) (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)]
((_ test ...) [(_ test ...)
(eq? (syntax-local-context) 'expression) (eq? (syntax-local-context) 'expression)
(raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx)))) (raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx)]))
;check-values-expected: (-> scheme-val) scheme-val src -> void ;; check-values-expected: (-> scheme-val) scheme-val src -> void
(define (check-values-expected test actual src test-info) (define (check-values-expected test actual src test-info)
(error-check (lambda (v) (if (number? v) (exact? v) #t)) (error-check (lambda (v) (if (number? v) (exact? v) #t))
actual INEXACT-NUMBERS-FMT) actual INEXACT-NUMBERS-FMT)
(send (send test-info get-info) add-check) (send (send test-info get-info) add-check)
@ -147,94 +148,105 @@
(lambda (src v1 v2 _) (make-unequal src v1 v2)) (lambda (src v1 v2 _) (make-unequal src v1 v2))
test actual #f src test-info)) test actual #f src test-info))
(define-syntax (check-within stx) (define-syntax (check-within stx)
(syntax-case stx () (syntax-case stx ()
((_ test actual within) [(_ test actual within)
(not (eq? (syntax-local-context) 'expression)) (not (eq? (syntax-local-context) 'expression))
(quasisyntax/loc stx (quasisyntax/loc stx
(define #,(gensym 'test-within) (define #,(gensym 'test-within)
(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))]) (let ([test-info (namespace-variable-value
'test~object #f builder (current-namespace))])
(when test-info (when test-info
(insert test-info (insert test-info
(lambda () (lambda ()
(check-values-within (lambda () test) actual within (check-values-within
(lambda () test) actual within
(list #,@(list (syntax-source stx) (list #,@(list (syntax-source stx)
(syntax-line stx) (syntax-line stx)
(syntax-column stx) (syntax-column stx)
(syntax-position stx) (syntax-position stx)
(syntax-span stx))) (syntax-span stx)))
test-info)))))))) test-info)))))))]
((_ test actual) [(_ test actual)
(not (eq? (syntax-local-context) 'expression)) (not (eq? (syntax-local-context) 'expression))
(raise-syntax-error 'check-within CHECK-WITHIN-STR stx)) (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]
((_ test) [(_ test)
(not (eq? (syntax-local-context) 'expression)) (not (eq? (syntax-local-context) 'expression))
(raise-syntax-error 'check-within CHECK-WITHIN-STR stx)) (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]
((_ test actual within extra ...) [(_ test actual within extra ...)
(not (eq? (syntax-local-context) 'expression)) (not (eq? (syntax-local-context) 'expression))
(raise-syntax-error 'check-within CHECK-WITHIN-STR stx)) (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]
((_ test ...) [(_ test ...)
(eq? (syntax-local-context) 'expression) (eq? (syntax-local-context) 'expression)
(raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx)))) (raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx)]))
(define (check-values-within test actual within src test-info) (define (check-values-within test actual within src test-info)
(error-check number? within CHECK-WITHIN-INEXACT-FMT) (error-check number? within CHECK-WITHIN-INEXACT-FMT)
(send (send test-info get-info) add-check) (send (send test-info get-info) add-check)
(run-and-check beginner-equal~? make-outofrange test actual within src test-info)) (run-and-check beginner-equal~? make-outofrange test actual within src
test-info))
(define-syntax (check-error stx) (define-syntax (check-error stx)
(syntax-case stx () (syntax-case stx ()
((_ test error) [(_ test error)
(not (eq? (syntax-local-context) 'expression)) (not (eq? (syntax-local-context) 'expression))
(quasisyntax/loc stx (quasisyntax/loc stx
(define #,(gensym 'test-error) (define #,(gensym 'test-error)
(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))]) (let ([test-info (namespace-variable-value
'test~object #f builder (current-namespace))])
(when test-info (when test-info
(insert-test test-info (insert-test test-info
(lambda () (lambda ()
(check-values-error (lambda () test) error (list #,@(list (syntax-source stx) (check-values-error
(lambda () test) error
(list #,@(list (syntax-source stx)
(syntax-line stx) (syntax-line stx)
(syntax-column stx) (syntax-column stx)
(syntax-position stx) (syntax-position stx)
(syntax-span stx))) (syntax-span stx)))
test-info)))))))) test-info)))))))]
((_ test) [(_ test)
(not (eq? (syntax-local-context) 'expression)) (not (eq? (syntax-local-context) 'expression))
(raise-syntax-error 'check-error CHECK-ERROR-STR stx)) (raise-syntax-error 'check-error CHECK-ERROR-STR stx)]
((_ test ...) [(_ test ...)
(eq? (syntax-local-context) 'expression) (eq? (syntax-local-context) 'expression)
(raise-syntax-error 'check-error CHECK-ERROR-DEFN-STR stx)))) (raise-syntax-error 'check-error CHECK-ERROR-DEFN-STR stx)]))
(define (check-values-error test error src test-info) (define (check-values-error test error src test-info)
(error-check string? error CHECK-ERROR-STR-FMT) (error-check string? error CHECK-ERROR-STR-FMT)
(send (send test-info get-info) add-check) (send (send test-info get-info) add-check)
(let ([result (with-handlers ((exn? (let ([result (with-handlers ([exn?
(lambda (e) (lambda (e)
(or (equal? (exn-message e) error) (or (equal? (exn-message e) error)
(make-incorrect-error src error (exn-message e)))))) (make-incorrect-error src error
(exn-message e))))])
(let ([test-val (test)]) (let ([test-val (test)])
(make-expected-error src error test-val)))]) (make-expected-error src error test-val)))])
(when (check-fail? result) (when (check-fail? result)
(send (send test-info get-info) check-failed (check->message result) (check-fail-src result))))) (send (send test-info get-info) check-failed
(check->message result) (check-fail-src result)))))
(define (error-check pred? actual fmt) (define (error-check pred? actual fmt)
(unless (pred? actual) (unless (pred? actual)
(raise (make-exn:fail:contract (format fmt actual) (raise (make-exn:fail:contract (format fmt actual)
(current-continuation-marks))))) (current-continuation-marks)))))
;run-and-check: (scheme-val scheme-val scheme-val -> boolean) ;; run-and-check: (scheme-val scheme-val scheme-val -> boolean)
; (scheme-val scheme-val scheme-val -> check-fail) ;; (scheme-val scheme-val scheme-val -> check-fail)
; ( -> scheme-val) scheme-val scheme-val object -> void ;; ( -> scheme-val) scheme-val scheme-val object -> void
(define (run-and-check check maker test expect range src test-info) (define (run-and-check check maker test expect range src test-info)
(let ([result (let ([result
(with-handlers ((exn? (lambda (e) (make-unexpected-error src expect (exn-message e))))) (with-handlers ([exn? (lambda (e)
(make-unexpected-error src expect
(exn-message e)))])
(let ([test-val (test)]) (let ([test-val (test)])
(or (check test-val expect range) (or (check test-val expect range)
(maker src test-val expect range))))]) (maker src test-val expect range))))])
(when (check-fail? result) (when (check-fail? result)
(send (send test-info get-info) check-failed (check->message result) (check-fail-src result))))) (send (send test-info get-info) check-failed (check->message result)
(check-fail-src result)))))
(define (check->message fail) (define (check->message fail)
(cond (cond
[(unexpected-error? fail) [(unexpected-error? fail)
(list "check encountered the following error instead of the expected value, " (list "check encountered the following error instead of the expected value, "
@ -254,13 +266,14 @@
".\n")] ".\n")]
[(incorrect-error? fail) [(incorrect-error? fail)
(list (format "check-error encountered the following error instead of the expected ~a~n :: ~a ~n" (list (format "check-error encountered the following error instead of the expected ~a~n :: ~a ~n"
(incorrect-error-expected fail) (incorrect-error-message fail)))] (incorrect-error-expected fail)
(incorrect-error-message fail)))]
[(expected-error? fail) [(expected-error? fail)
(list "check-error expected the following error, but instead received the value " (list "check-error expected the following error, but instead received the value "
(format-value (expected-error-value fail)) (format-value (expected-error-value fail))
(format ".~n ~a~n" (expected-error-message fail)))])) (format ".~n ~a~n" (expected-error-message fail)))]))
(define (format-value value) (define (format-value value)
(cond (cond
[(is-a? value snip%) value] [(is-a? value snip%) value]
[(or (pair? value) (struct? value)) [(or (pair? value) (struct? value))
@ -272,5 +285,3 @@
(send text* lock #t) (send text* lock #t)
text-snip))] text-snip))]
[else (format "~v" value)])) [else (format "~v" value)]))
)

89
collects/test-engine/test-coverage.scm
View File

@ -1,29 +1,34 @@
(module test-coverage mzscheme #lang mzscheme
(require (lib "class.ss") (require mzlib/class
(lib "mred.ss" "mred") mred
(lib "framework.ss" "framework") framework
(prefix list: (lib "list.ss")) (prefix list: mzlib/list)
(lib "integer-set.ss")) mzlib/integer-set)
(provide (all-defined)) (provide (all-defined))
(define coverage-track% (define coverage-track%
(class* object% () (class* object% ()
(super-instantiate ()) (super-instantiate ())
(define covered (make-range)) ; interger-set ;; interger-set
(define covered-from-src (make-hash-table 'weak));[hashtable-of scheme-val -> integer-set] (define covered (make-range))
(define current-coverage-srcs null); (listof covered-from-src keys) ;; [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) (define/public (covered-position start span)
(let ([new-range (make-range start (+ start span))]) (let ([new-range (make-range start (+ start span))])
(set! covered (union covered new-range)) (set! covered (union covered new-range))
(for-each (lambda (key covered-set) (for-each (lambda (key covered-set)
(hash-table-put! covered-from-src key (union covered-set new-range))) (hash-table-put! covered-from-src key
(union covered-set new-range)))
current-coverage-srcs current-coverage-srcs
(map (lambda (key) (hash-table-get covered-from-src key (make-range))) (map (lambda (key)
(hash-table-get covered-from-src key (make-range)))
current-coverage-srcs)))) current-coverage-srcs))))
(define/public (register-coverage-point src) (define/public (register-coverage-point src)
@ -42,7 +47,8 @@
(highlight-covered editor covered)) (highlight-covered editor covered))
(define/public (display-covered-portion editor coverage-point) (define/public (display-covered-portion editor coverage-point)
(highlight-covered editor (hash-table-get covered-from-src coverage-point (make-range)))) (highlight-covered editor (hash-table-get covered-from-src coverage-point
(make-range))))
(define/private (highlight-covered editor int-set) (define/private (highlight-covered editor int-set)
@ -54,9 +60,10 @@
(letrec ([color-buff (letrec ([color-buff
(lambda () (lambda ()
(cond (cond
((or (send editor is-locked?) (send editor in-edit-sequence?)) [(or (send editor is-locked?)
(queue-callback color-buff)) (send editor in-edit-sequence?))
(else (queue-callback color-buff)]
[else
(unless (send editor test-froze-colorer?) (unless (send editor test-froze-colorer?)
(send editor freeze-colorer) (send editor freeze-colorer)
(send editor toggle-test-status)) (send editor toggle-test-status))
@ -68,32 +75,29 @@
(unless (null? positions) (unless (null? positions)
(send editor change-style covered-highlight (send editor change-style covered-highlight
(sub1 (caar positions)) (sub1 (caar positions))
(sub1 (cdar positions)) #f) (sub1 (cdar positions))
#f)
(loop (cdr positions)))) (loop (cdr positions))))
(send editor end-test-color))))]) (send editor end-test-color)]))])
(queue-callback color-buff)))) (queue-callback color-buff))))))
)
)
(define (test-coverage-button-mixin parent)
(define (test-coverage-button-mixin parent)
(class* parent () (class* parent ()
(super-instantiate ()) (super-instantiate ())
(define/public (insert-covered-button dest coverage src src-editor partial?) (define/public (insert-covered-button dest coverage src src-editor partial?)
(let* ((button-editor (new (editor:standard-style-list-mixin text%) (let* ([button-editor (new (editor:standard-style-list-mixin text%)
[auto-wrap #t])) [auto-wrap #t])]
(snip (new editor-snip% (editor button-editor) (with-border? #t))) [snip (new editor-snip% (editor button-editor) (with-border? #t))]
(start (send dest get-end-position))) [start (send dest get-end-position)])
(send snip set-style (send snip set-style
(send (send dest get-style-list) find-named-style "Standard")) (send (send dest get-style-list) find-named-style "Standard"))
(send button-editor insert
(if partial? (if partial?
(send button-editor insert "Highlight covered expressions") "Highlight covered expressions"
(send button-editor insert "Highlight all covered expressions")) "Highlight all covered expressions"))
(send dest insert snip) (send dest insert snip)
(send button-editor set-clickback (send button-editor set-clickback 0
0
(send button-editor get-end-position) (send button-editor get-end-position)
(cond (cond
[(and src-editor partial?) [(and src-editor partial?)
@ -104,20 +108,18 @@
(send coverage display-coverage src-editor))] (send coverage display-coverage src-editor))]
[else (lambda (t s e) (void))]) [else (lambda (t s e) (void))])
#f #f) #f #f)
(let ((c (new style-delta%))) (let ([c (new style-delta%)])
(send c set-delta-foreground "royalblue") (send c set-delta-foreground "royalblue")
(send dest change-style c start (sub1 (send dest get-end-position)) #f)) (send dest change-style c start (sub1 (send dest get-end-position))
)) #f))))))
)
)
(define analysis<%> (define analysis<%>
(interface () (interface ()
register-test register-testcase register-test register-testcase
de-register-test de-register-testcase de-register-test de-register-testcase
analyze provide-info)) analyze provide-info))
(define coverage-analysis% (define coverage-analysis%
(class* object% (analysis<%>) (class* object% (analysis<%>)
(define coverage-info (make-object coverage-track%)) (define coverage-info (make-object coverage-track%))
@ -134,9 +136,4 @@
(send coverage-info covered-position (list-ref src 3) (list-ref src 4))) (send coverage-info covered-position (list-ref src 3) (list-ref src 4)))
(define/public (provide-info) coverage-info) (define/public (provide-info) coverage-info)
(super-instantiate ()) (super-instantiate ())))
))
)

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

@ -1,14 +1,13 @@
(module test-display scheme/base #lang scheme/base
(require scheme/class (require scheme/class
scheme/file scheme/file
(lib "mred.ss" "mred") mred
(lib "framework.ss" "framework") framework
(lib "string-constant.ss" "string-constants")) string-constants
"test-info.scm")
(require "test-info.scm") (define test-display%
(define test-display%
(class* object% () (class* object% ()
(init-field (current-rep #f)) (init-field (current-rep #f))
@ -27,9 +26,9 @@
(set! src-editor ed)) (set! src-editor ed))
(define/public (display-results) (define/public (display-results)
(let* ((curr-win (and current-tab (send current-tab get-test-window))) (let* ([curr-win (and current-tab (send current-tab get-test-window))]
(window (or curr-win (make-object test-window%))) [window (or curr-win (make-object test-window%))]
(content (make-object (editor:standard-style-list-mixin text%)))) [content (make-object (editor:standard-style-list-mixin text%))])
(send this insert-test-results content test-info src-editor) (send this insert-test-results content test-info src-editor)
(send content lock #t) (send content lock #t)
@ -50,7 +49,10 @@
(send current-tab current-test-editor #f))))) (send current-tab current-test-editor #f)))))
(if (and drscheme-frame (if (and drscheme-frame
(get-preference 'profj:test-window:docked? (get-preference 'profj:test-window:docked?
(lambda () (put-preferences '(profj:test-window:docked?) '(#f)) #f))) (lambda ()
(put-preferences '(profj:test-window:docked?)
'(#f))
#f)))
(send drscheme-frame display-test-panel content) (send drscheme-frame display-test-panel content)
(send window show #t)))) (send window show #t))))
@ -70,7 +72,8 @@
(when (> total-tests 0) (when (> total-tests 0)
(send editor insert (send editor insert
(cond (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"] [(zero? failed-tests) "All tests passed!\n\n"]
[(= failed-tests total-tests) "0 tests passed.\n"] [(= failed-tests total-tests) "0 tests passed.\n"]
[else "~a of the ~a tests failed.\n\n"]))))] [else "~a of the ~a tests failed.\n\n"]))))]
@ -84,11 +87,12 @@
(when (> total-checks 0) (when (> total-checks 0)
(send editor insert (send editor insert
(cond (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"] [(zero? failed-checks) "All checks passed!\n\n"]
[(= failed-checks total-checks) "0 checks passed.\n"] [(= failed-checks total-checks) "0 checks passed.\n"]
[else [else (format "~a of the ~a checks failed.\n\n"
(format "~a of the ~a checks failed.\n\n" failed-checks total-checks)]))))]) failed-checks total-checks)]))))])
(case style (case style
[(test-require) [(test-require)
(test-outcomes "This program must be tested!\n") (test-outcomes "This program must be tested!\n")
@ -103,40 +107,37 @@
(unless (and (zero? total-checks) (zero? total-tests)) (unless (and (zero? total-checks) (zero? total-tests))
(inner (display-check-failures (send test-info failed-checks) (inner (display-check-failures (send test-info failed-checks)
editor test-info src-editor) editor test-info src-editor)
insert-test-results editor test-info src-editor)) insert-test-results editor test-info src-editor))))
))
(define/public (display-check-failures checks editor test-info src-editor) (define/public (display-check-failures checks editor test-info src-editor)
(for-each (for ([failed-check (reverse checks)])
(lambda (failed-check)
(send editor insert "\t") (send editor insert "\t")
(make-link editor (make-link editor
(failed-check-msg failed-check) (failed-check-msg failed-check)
(failed-check-src failed-check) (failed-check-src failed-check)
src-editor) src-editor)
(send editor insert "\n")) (send editor insert "\n")))
(reverse checks)))
(define/public (next-line editor) (send editor insert "\n\t")) (define/public (next-line editor) (send editor insert "\n\t"))
;make-link: text% (listof (U string snip%)) src editor -> void ;; make-link: text% (listof (U string snip%)) src editor -> void
(define (make-link text msg dest src-editor) (define (make-link text msg dest src-editor)
(for-each (lambda (m) (for ([m msg])
(when (is-a? m snip%) (when (is-a? m snip%)
(send m set-style (send (send text get-style-list) (send m set-style (send (send text get-style-list)
find-named-style "Standard"))) find-named-style "Standard")))
(send text insert m)) msg) (send text insert m))
(let ((start (send text get-end-position))) (let ((start (send text get-end-position)))
(send text insert (format-src dest)) (send text insert (format-src dest))
(send text set-clickback (send text set-clickback
start (send text get-end-position) start (send text get-end-position)
(lambda (t s e) (lambda (t s e) (highlight-check-error dest src-editor))
(highlight-check-error dest src-editor))
#f #f) #f #f)
(let ((end (send text get-end-position)) (let ([end (send text get-end-position)]
(c (new style-delta%))) [c (new style-delta%)])
(send text insert " ") (send text insert " ")
(send text change-style (make-object style-delta% 'change-underline #t) (send text change-style
(make-object style-delta% 'change-underline #t)
start end #f) start end #f)
(send c set-delta-foreground "royalblue") (send c set-delta-foreground "royalblue")
(send text change-style c start end #f)))) (send text change-style c start end #f))))
@ -148,8 +149,8 @@
(string-append (string-append
(cond (cond
[(symbol? (src-file src)) (string-append " At ")] [(symbol? (src-file src)) (string-append " At ")]
((path? (src-file src)) (string-append " In " (src-file src) " at ")) [(path? (src-file src)) (string-append " In " (src-file src) " at ")]
((is-a? (src-file src) editor<%>) " At ")) [(is-a? (src-file src) editor<%>) " At "])
"line " (number->string (src-line src)) "line " (number->string (src-line src))
" column " (number->string (src-col src))))) " column " (number->string (src-col src)))))
@ -172,7 +173,7 @@
(super-instantiate ()))) (super-instantiate ())))
(define test-window% (define test-window%
(class* frame% () (class* frame% ()
(super-instantiate (super-instantiate
@ -186,7 +187,8 @@
(define content (define content
(make-object editor-canvas% this #f '(auto-vscroll))) (make-object editor-canvas% this #f '(auto-vscroll)))
(define button-panel (make-object horizontal-panel% this (define button-panel
(make-object horizontal-panel% this
'() #t 0 0 0 0 '(right bottom) 0 0 #t #f)) '() #t 0 0 0 0 '(right bottom) 0 0 #t #f))
(define buttons (define buttons
@ -211,11 +213,11 @@
(lambda (b c) (lambda (b c)
(when (eq? 'button (send c get-event-type)) (when (eq? 'button (send c get-event-type))
(send this show #f) (send this show #f)
(put-preferences '(profj:test-window:docked?) '(#t)) (put-preferences '(profj:test-window:docked?)
'(#t))
(switch-func)))) (switch-func))))
(make-object grow-box-spacer-pane% button-panel))) (make-object grow-box-spacer-pane% button-panel)))
(define/public (update-editor e) (define/public (update-editor e)
(set! editor e) (set! editor e)
(send content set-editor editor)) (send content set-editor editor))
@ -225,21 +227,20 @@
(define/public (update-closer thunk) (define/public (update-closer thunk)
(set! close-cleanup thunk)) (set! close-cleanup thunk))
(define/public (update-disable thunk) (define/public (update-disable thunk)
(set! disable-func thunk)) (set! disable-func thunk))))
))
(define test-panel% (define test-panel%
(class* vertical-panel% () (class* vertical-panel% ()
(inherit get-parent) (inherit get-parent)
(super-instantiate () ) (super-instantiate ())
(define content (make-object editor-canvas% this #f '())) (define content (make-object editor-canvas% this #f '()))
(define button-panel (make-object horizontal-panel% this (define button-panel (make-object horizontal-panel% this
'() #t 0 0 0 0 '(right bottom) 0 0 #t #f)) '() #t 0 0 0 0 '(right bottom) 0 0 #t #f))
(define (hide) (define (hide)
(let ((current-tab (send frame get-current-tab))) (let ([current-tab (send frame get-current-tab)])
(send frame deregister-test-window (send frame deregister-test-window
(send current-tab get-test-window)) (send current-tab get-test-window))
(send current-tab current-test-window #f) (send current-tab current-test-window #f)
@ -258,15 +259,15 @@
(lambda (b c) (lambda (b c)
(when (eq? 'button (send c get-event-type)) (when (eq? 'button (send c get-event-type))
(hide) (hide)
(send (send frame get-current-tab) update-test-preference #f)))) (send (send frame get-current-tab)
update-test-preference #f))))
(make-object button% (make-object button%
(string-constant undock) (string-constant undock)
button-panel button-panel
(lambda (b c) (lambda (b c)
(when (eq? 'button (send c get-event-type)) (when (eq? 'button (send c get-event-type))
(put-preferences '(profj:test-window:docked?) '(#f)) (put-preferences '(profj:test-window:docked?) '(#f))
(send frame undock-tests) (send frame undock-tests))))
)))
(define/public (update-editor e) (define/public (update-editor e)
(send content set-editor e)) (send content set-editor e))
@ -276,12 +277,12 @@
(set! frame f)) (set! frame f))
(define/public (remove) (define/public (remove)
(let ((parent (get-parent))) (let ([parent (get-parent)])
(put-preferences '(profj:test-dock-size) (list (send parent get-percentages))) (put-preferences '(profj:test-dock-size)
(send parent delete-child this))) (list (send parent get-percentages)))
)) (send parent delete-child this)))))
(define test-display-textual% (define test-display-textual%
(class* object% () (class* object% ()
(init-field (current-rep #f)) (init-field (current-rep #f))
@ -303,14 +304,14 @@
[test-outcomes [test-outcomes
(lambda (zero-message) (lambda (zero-message)
(printf "~a" (printf "~a"
(cond (cond [(zero? total-tests) zero-message]
[(zero? total-tests) zero-message]
[(= 1 total-tests) "Ran 1 test.\n"] [(= 1 total-tests) "Ran 1 test.\n"]
[else (format "Ran ~a tests.\n" total-tests)])) [else (format "Ran ~a tests.\n" total-tests)]))
(when (> total-tests 0) (when (> total-tests 0)
(printf "~a" (printf "~a"
(cond (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"] [(zero? failed-tests) "All tests passed!\n\n"]
[(= failed-tests total-tests) "0 tests passed.\n"] [(= failed-tests total-tests) "0 tests passed.\n"]
[else "~a of the ~a tests failed.\n\n"]))))] [else "~a of the ~a tests failed.\n\n"]))))]
@ -324,11 +325,12 @@
(when (> total-checks 0) (when (> total-checks 0)
(printf "~a" (printf "~a"
(cond (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"] [(zero? failed-checks) "All checks passed!\n\n"]
[(= failed-checks total-checks) "0 checks passed.\n"] [(= failed-checks total-checks) "0 checks passed.\n"]
[else [else (format "~a of the ~a checks failed.\n\n"
(format "~a of the ~a checks failed.\n\n" failed-checks total-checks)]))))]) failed-checks total-checks)]))))])
(case style (case style
[(test-require) [(test-require)
(test-outcomes "This program must be tested!\n") (test-outcomes "This program must be tested!\n")
@ -341,25 +343,22 @@
[else (check-outcomes "")]) [else (check-outcomes "")])
(unless (and (zero? total-checks) (zero? total-tests)) (unless (and (zero? total-checks) (zero? total-tests))
(inner (display-check-failures (send test-info failed-checks) test-info) (inner (display-check-failures (send test-info failed-checks)
insert-test-results test-info)) test-info)
)) insert-test-results test-info))))
(define/public (display-check-failures checks test-info) (define/public (display-check-failures checks test-info)
(for-each (for ([failed-check (reverse checks)])
(lambda (failed-check)
(printf "~a" "\t") (printf "~a" "\t")
(make-link (failed-check-msg failed-check) (make-link (failed-check-msg failed-check)
(failed-check-src failed-check) (failed-check-src failed-check))
) (printf "~a" "\n")))
(printf "~a" "\n"))
(reverse checks)))
(define/public (next-line) (printf "~a" "\n\t")) (define/public (next-line) (printf "~a" "\n\t"))
;make-link: (listof (U string snip%)) src -> void ;; make-link: (listof (U string snip%)) src -> void
(define (make-link msg dest) (define (make-link msg dest)
(for-each (lambda (m) (printf m)) msg) (for-each printf msg)
(printf (format-src dest))) (printf (format-src dest)))
(define (format-src src) (define (format-src src)
@ -367,15 +366,13 @@
[src-line cadr] [src-line cadr]
[src-col caddr]) [src-col caddr])
(string-append (string-append
(cond (cond [(symbol? (src-file src)) " At "]
[(symbol? (src-file src)) (string-append " At ")] [(path? (src-file src))
((path? (src-file src)) (string-append " In " (path->string (src-file src)) " at ")) (string-append " In " (path->string (src-file src)) " at ")]
((is-a? (src-file src) editor<%>) " At ")) [(is-a? (src-file src) editor<%>) " At "])
"line " (number->string (src-line src)) "line " (number->string (src-line src))
" column " (number->string (src-col src))))) " column " (number->string (src-col src)))))
(super-instantiate ()))) (super-instantiate ())))
(provide test-panel% test-window% test-display% test-display-textual%) (provide test-panel% test-window% test-display% test-display-textual%)
)

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

@ -1,10 +1,10 @@
(module test-engine scheme/base #lang scheme/base
(require scheme/class (require scheme/class
"test-info.scm" "test-info.scm"
"test-display.scm") "test-display.scm")
(define test-engine% (define test-engine%
(class* object% () (class* object% ()
(field [test-info #f] (field [test-info #f]
[test-display #f]) [test-display #f])
@ -37,7 +37,8 @@
(case result (case result
[(no-tests) (send this display-untested port)] [(no-tests) (send this display-untested port)]
[(all-passed) (send this display-success port)] [(all-passed) (send this display-success port)]
[(mixed-results) (send this display-results display-rep display-event-space)]))) [(mixed-results)
(send this display-results display-rep display-event-space)])))
(define/public (display-success port) (define/public (display-success port)
(fprintf port "All tests passed!~n")) (fprintf port "All tests passed!~n"))
@ -46,17 +47,19 @@
(define/public (display-results rep event-space) (define/public (display-results rep event-space)
(send test-display install-info test-info) (send test-display install-info test-info)
(if event-space (if event-space
(parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space]) (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace)
event-space])
((dynamic-require 'scheme/gui 'queue-callback) ((dynamic-require 'scheme/gui 'queue-callback)
(lambda () (send rep display-test-results test-display)))) (lambda () (send rep display-test-results test-display))))
(send test-display display-results))) (send test-display display-results)))
(define/pubment (initialize-test test) (inner (void) initialize-test test)) (define/pubment (initialize-test test)
(inner (void) initialize-test test))
(define/pubment (run-test test) (inner (void) run-test test)) (define/pubment (run-test test)
(inner (void) run-test test))
(define/pubment (run-testcase testcase) (inner (void) run-testcase testcase)))) (define/pubment (run-testcase testcase)
(inner (void) run-testcase testcase))))
(provide test-engine%) (provide test-engine%)
)

25
collects/test-engine/test-info.scm
View File

@ -1,15 +1,14 @@
(module test-info scheme/base #lang scheme/base
(require scheme/class) (require scheme/class)
(provide (all-defined-out)) (provide (all-defined-out))
;(make-failed-check src (listof (U string snip%))) ;; (make-failed-check src (listof (U string snip%)))
(define-struct failed-check (src msg)) (define-struct failed-check (src msg))
(define test-info-base% (define test-info-base%
(class* object% () (class* object% ()
(super-instantiate ()) (super-instantiate ())
(init-field (style 'check-base)) (init-field (style 'check-base))
@ -28,8 +27,7 @@
(define/public (checks-run) total-cks) (define/public (checks-run) total-cks)
(define/public (checks-failed) failed-cks) (define/public (checks-failed) failed-cks)
(define/public (summarize-results) (define/public (summarize-results)
(cond (cond [(and (zero? total-tsts) (zero? total-cks)) 'no-tests]
[(and (zero? total-tsts) (zero? total-cks)) 'no-tests]
[(and (zero? failed-cks) (zero? failed-tsts)) 'all-passed] [(and (zero? failed-cks) (zero? failed-tsts)) 'all-passed]
[else 'mixed-results])) [else 'mixed-results]))
@ -43,7 +41,7 @@
(set! total-tsts (add1 total-tsts)) (set! total-tsts (add1 total-tsts))
(inner (void) add-test)) (inner (void) add-test))
;check-failed: (list (U string snip%)) src -> void ;; check-failed: (list (U string snip%)) src -> void
(define/pubment (check-failed msg src) (define/pubment (check-failed msg src)
(set! failed-cks (add1 failed-cks)) (set! failed-cks (add1 failed-cks))
(set! failures (cons (make-failed-check src msg) failures)) (set! failures (cons (make-failed-check src msg) failures))
@ -56,9 +54,6 @@
(define/public (add-analysis a) (set! analyses (cons a analyses))) (define/public (add-analysis a) (set! analyses (cons a analyses)))
(define/public (analyze-position src . vals) (define/public (analyze-position src . vals)
(for-each (lambda (a) (send a analyze src vals)) analyses)) (for ([a analyses]) (send a analyze src vals)))
(define/public (extract-info pred?) (define/public (extract-info pred?)
(filter pred? (map (lambda (a) (send a provide-info)) analyses))) (filter pred? (map (lambda (a) (send a provide-info)) analyses)))))
))
)

77
collects/test-engine/test-tool.scm
View File

@ -1,20 +1,18 @@
(module test-tool scheme/base #lang scheme/base
(require scheme/file scheme/class scheme/unit drscheme/tool framework mred) (require scheme/file scheme/class scheme/unit drscheme/tool framework mred)
(require "test-display.scm") (require "test-display.scm")
(provide tool@) (provide tool@)
(define tool@
(unit (import drscheme:tool^) (export drscheme:tool-exports^)
(define tool@
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
(define (phase1) (void)) (define (phase1) (void))
(define (phase2) (void)) (define (phase2) (void))
;Overriding interactions as the current-rep implementation ;; Overriding interactions as the current-rep implementation
(define (test-interactions-text%-mixin %) (define (test-interactions-text%-mixin %)
(class* % () (class* % ()
(inherit get-top-level-window get-definitions-text) (inherit get-top-level-window get-definitions-text)
(define/public (display-test-results test-display) (define/public (display-test-results test-display)
@ -25,9 +23,7 @@
(send test-display display-settings dr-frame tab ed-def) (send test-display display-settings dr-frame tab ed-def)
(send test-display display-results)))) (send test-display display-results))))
(super-instantiate ()) (super-instantiate ())))
)
)
(define (test-definitions-text%-mixin %) (define (test-definitions-text%-mixin %)
(class* % () (class* % ()
@ -68,17 +64,16 @@
(define (test-frame-mixin %) (define (test-frame-mixin %)
(class* % () (class* % ()
(inherit get-current-tab) (inherit get-current-tab)
(define/public (display-test-panel editor) (define/public (display-test-panel editor)
(send test-panel update-editor editor) (send test-panel update-editor editor)
(unless (send test-panel is-shown?) (unless (send test-panel is-shown?)
(send test-frame add-child test-panel) (send test-frame add-child test-panel)
(let ((test-box-size (let ([test-box-size
(get-preference 'profj:test-dock-size (lambda () '(2/3 1/3))))) (get-preference 'profj:test-dock-size
(send test-frame set-percentages test-box-size)) (lambda () '(2/3 1/3)))])
)) (send test-frame set-percentages test-box-size))))
(define test-panel null) (define test-panel null)
(define test-frame null) (define test-frame null)
@ -89,15 +84,16 @@
(set! test-windows (remq t test-windows))) (set! test-windows (remq t test-windows)))
(define/public (dock-tests) (define/public (dock-tests)
(for-each (lambda (t) (send t show #f)) test-windows) (for ([t test-windows]) (send t show #f))
(let ((ed (send (get-current-tab) get-test-editor))) (let ([ed (send (get-current-tab) get-test-editor)])
(when ed (display-test-panel ed)))) (when ed (display-test-panel ed))))
(define/public (undock-tests) (define/public (undock-tests)
(send test-panel remove) (send test-panel remove)
(for-each (lambda (t) (send t show #t)) test-windows)) (for ([t test-windows]) (send t show #t)))
(define/override (make-root-area-container cls parent) (define/override (make-root-area-container cls parent)
(let* ([outer-p (super make-root-area-container panel:vertical-dragable% parent)] (let* ([outer-p (super make-root-area-container
panel:vertical-dragable% parent)]
[louter-panel (make-object vertical-panel% outer-p)] [louter-panel (make-object vertical-panel% outer-p)]
[test-p (make-object test-panel% outer-p '(deleted))] [test-p (make-object test-panel% outer-p '(deleted))]
[root (make-object cls louter-panel)]) [root (make-object cls louter-panel)])
@ -107,24 +103,23 @@
root)) root))
(define/augment (on-tab-change from-tab to-tab) (define/augment (on-tab-change from-tab to-tab)
(let ((test-editor (send to-tab get-test-editor)) (let ([test-editor (send to-tab get-test-editor)]
(panel-shown? (send test-panel is-shown?)) [panel-shown? (send test-panel is-shown?)]
(dock? (get-preference 'profj:test-window:docked? (lambda () #f)))) [dock? (get-preference 'profj:test-window:docked?
(cond (lambda () #f))])
((and test-editor panel-shown? dock?) (cond [(and test-editor panel-shown? dock?)
(send test-panel update-editor test-editor)) (send test-panel update-editor test-editor)]
((and test-editor dock?) [(and test-editor dock?)
(display-test-panel test-editor)) (display-test-panel test-editor)]
((and panel-shown? (not dock?)) [(and panel-shown? (not dock?))
(undock-tests)) (undock-tests)]
(panel-shown? (send test-panel remove))) [panel-shown? (send test-panel remove)])
(inner (void) on-tab-change from-tab to-tab))) (inner (void) on-tab-change from-tab to-tab)))
(super-instantiate () ))) (super-instantiate ())))
(define (test-tab%-mixin %) (define (test-tab%-mixin %)
(class* % () (class* % ()
(inherit get-frame get-defs) (inherit get-frame get-defs)
(define test-editor #f) (define test-editor #f)
@ -146,10 +141,12 @@
[settings [settings
(drscheme:language-configuration:language-settings-settings (drscheme:language-configuration:language-settings-settings
language-settings)]) language-settings)])
(when (object-method-arity-includes? language 'update-test-setting 2) (when (object-method-arity-includes? language
(let ((next-setting (drscheme:language-configuration:make-language-settings 'update-test-setting 2)
(let ([next-setting
(drscheme:language-configuration:make-language-settings
language language
(send language update-test-setting settings test?)))) (send language update-test-setting settings test?))])
(preferences:set (preferences:set
(drscheme:language-configuration:get-settings-preferences-symbol) (drscheme:language-configuration:get-settings-preferences-symbol)
next-setting) next-setting)
@ -162,7 +159,7 @@
(send (get-frame) deregister-test-window test-window)) (send (get-frame) deregister-test-window test-window))
(inner (void) on-close)) (inner (void) on-close))
(super-instantiate () ))) (super-instantiate ())))
(drscheme:get/extend:extend-definitions-text test-definitions-text%-mixin) (drscheme:get/extend:extend-definitions-text test-definitions-text%-mixin)
(drscheme:get/extend:extend-interactions-text test-interactions-text%-mixin) (drscheme:get/extend:extend-interactions-text test-interactions-text%-mixin)
@ -170,5 +167,3 @@
(drscheme:get/extend:extend-tab test-tab%-mixin) (drscheme:get/extend:extend-tab test-tab%-mixin)
)) ))
)