diff --git a/collects/test-engine/info.ss b/collects/test-engine/info.ss index f4c3bf1284..b3d8151bf4 100644 --- a/collects/test-engine/info.ss +++ b/collects/test-engine/info.ss @@ -1,5 +1,4 @@ -(module info setup/infotab - (define name "Test Engine") - (define tools (list (list "test-tool.scm"))) - (define tool-names '("Test Engine")) - ) \ No newline at end of file +#lang setup/infotab + +(define tools (list (list "test-tool.scm"))) +(define tool-names '("Test Engine")) diff --git a/collects/test-engine/java-tests.scm b/collects/test-engine/java-tests.scm index 9bf68d7f2d..0c945c7e2c 100644 --- a/collects/test-engine/java-tests.scm +++ b/collects/test-engine/java-tests.scm @@ -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%) - - ) \ No newline at end of file +(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%) diff --git a/collects/test-engine/scheme-gui.scm b/collects/test-engine/scheme-gui.scm index 4c9a0a3558..e36811ac34 100644 --- a/collects/test-engine/scheme-gui.scm +++ b/collects/test-engine/scheme-gui.scm @@ -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) - ) \ No newline at end of file +#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) diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index c46b80289d..51e7c65ae0 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -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 ) - check-within ;; syntax : (check-within ) - check-error ;; syntax : (check-error ) - - ) +(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 ) + check-within ;; syntax : (check-within ) + check-error ;; syntax : (check-error ) + ) - - (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)])) diff --git a/collects/test-engine/test-coverage.scm b/collects/test-engine/test-coverage.scm index 5c0918b5a0..72ef1aa740 100644 --- a/collects/test-engine/test-coverage.scm +++ b/collects/test-engine/test-coverage.scm @@ -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 ()) - )) - - - - ) \ No newline at end of file +#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 ()))) diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index c53ae523f0..1c099db48c 100644 --- a/collects/test-engine/test-display.scm +++ b/collects/test-engine/test-display.scm @@ -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%) - - ) \ No newline at end of file + +(provide test-panel% test-window% test-display% test-display-textual%) diff --git a/collects/test-engine/test-engine.scm b/collects/test-engine/test-engine.scm index dbc98c815e..68d895ff87 100644 --- a/collects/test-engine/test-engine.scm +++ b/collects/test-engine/test-engine.scm @@ -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%) - - ) \ No newline at end of file +#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%) diff --git a/collects/test-engine/test-info.scm b/collects/test-engine/test-info.scm index 748d81c07a..98e475eca1 100644 --- a/collects/test-engine/test-info.scm +++ b/collects/test-engine/test-info.scm @@ -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))) - - )) - ) \ No newline at end of file +(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))))) diff --git a/collects/test-engine/test-tool.scm b/collects/test-engine/test-tool.scm index 5eb40b6947..e21b895461 100644 --- a/collects/test-engine/test-tool.scm +++ b/collects/test-engine/test-tool.scm @@ -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) + + ))