From 7a6dff6d1978cfd589ec9272066a86d74605b69b Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Fri, 4 Apr 2008 11:30:36 +0000 Subject: [PATCH] Merging testing branch (kathyg/test-harnessv4-2) onto trunk: -r8903:9138 svn: r9160 --- collects/htdp/testing.ss | 282 ------------- collects/lang/htdp-advanced.ss | 6 +- collects/lang/htdp-beginner-abbr.ss | 8 +- collects/lang/htdp-beginner.ss | 9 +- collects/lang/htdp-intermediate-lambda.ss | 7 +- collects/lang/htdp-intermediate.ss | 7 +- collects/lang/htdp-langs.ss | 22 +- collects/lang/private/teachprims.ss | 4 +- collects/lang/run-teaching-program.ss | 27 +- collects/profj/ast.ss | 6 + collects/profj/check.ss | 68 +++- collects/profj/info.ss | 4 +- collects/profj/libs/java/runtime.scm | 79 +++- .../profj/libs/java/tester/TestBase.djava | 13 +- collects/profj/parsers/full-parser.ss | 2 + collects/profj/to-scheme.ss | 120 ++++-- collects/profj/tool.ss | 61 ++- collects/test-engine/info.ss | 5 + collects/test-engine/java-tests.scm | 349 ++++++++++++++++ collects/test-engine/scheme-gui.scm | 34 ++ collects/test-engine/scheme-tests.ss | 276 +++++++++++++ collects/test-engine/test-coverage.scm | 142 +++++++ collects/test-engine/test-display.scm | 381 ++++++++++++++++++ collects/test-engine/test-engine.scm | 62 +++ collects/test-engine/test-info.scm | 64 +++ collects/test-engine/test-tool.scm | 174 ++++++++ 26 files changed, 1837 insertions(+), 375 deletions(-) delete mode 100644 collects/htdp/testing.ss create mode 100644 collects/test-engine/info.ss create mode 100644 collects/test-engine/java-tests.scm create mode 100644 collects/test-engine/scheme-gui.scm create mode 100644 collects/test-engine/scheme-tests.ss create mode 100644 collects/test-engine/test-coverage.scm create mode 100644 collects/test-engine/test-display.scm create mode 100644 collects/test-engine/test-engine.scm create mode 100644 collects/test-engine/test-info.scm create mode 100644 collects/test-engine/test-tool.scm diff --git a/collects/htdp/testing.ss b/collects/htdp/testing.ss deleted file mode 100644 index e7f09974ee..0000000000 --- a/collects/htdp/testing.ss +++ /dev/null @@ -1,282 +0,0 @@ -(module testing mzscheme - - (require (lib "teachprims.ss" "lang" "private") - mred - framework - mzlib/pretty - mzlib/pconvert - mzlib/class) - - (require-for-syntax (lib "shared.ss" "stepper" "private")) - - (provide - check-expect ;; syntax : (check-expect ) - check-within ;; syntax : (check-within ) - check-error ;; syntax : (check-error ) - generate-report ;; -> true - ) - - (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") - - ;(make-src (U editor file-name) int int int) - (define-struct src (file line col pos span)) - - (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 - #`(check-values-expected - (lambda () test) actual (make-src #,@(list #`(quote #,(syntax-source stx)) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx)))) - `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) - (error-check (lambda (v) (if (number? v) (exact? v) #t)) - actual INEXACT-NUMBERS-FMT) - (update-num-checks) - (run-and-check (lambda (v1 v2 _) (beginner-equal? v1 v2)) - (lambda (src v1 v2 _) (make-unequal src v1 v2)) - test actual #f src)) - - (define-syntax (check-within stx) - (syntax-case stx () - ((_ test actual within) - (not (eq? (syntax-local-context) 'expression)) - (quasisyntax/loc stx - (define #,(gensym 'test-within) - (check-values-within (lambda () test) actual within - (make-src #,@(list (syntax-source stx) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx))))))) - ((_ 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) - (error-check number? within CHECK-WITHIN-INEXACT-FMT) - (update-num-checks) - (run-and-check beginner-equal~? make-outofrange test actual within src)) - - (define-syntax (check-error stx) - (syntax-case stx () - ((_ test error) - (not (eq? (syntax-local-context) 'expression)) - (quasisyntax/loc stx - (define #,(gensym 'test-error) - (check-values-error (lambda () test) error (make-src #,@(list (syntax-source stx) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx))))))) - ((_ 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) - (error-check string? error CHECK-ERROR-STR-FMT) - (update-num-checks) - (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) (update-failed-checks 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 -> void - (define (run-and-check check maker test expect range src) - (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) (update-failed-checks result)))) - - (define (update-num-checks) (set! num-checks (add1 num-checks))) - (define num-checks 0) - - (define failed-check null) - (define (update-failed-checks failure) (set! failed-check (cons failure failed-check))) - - (define (generate-report) - (let* ([num-failed-tests (length failed-check)]) - (cond - [(zero? num-failed-tests) - (fprintf (current-error-port) "All ~a check~a succeeded!\n" - num-checks - (if (= 1 num-checks) "" "s"))] - [else - (let* ([my-text (new (editor:standard-style-list-mixin text%))] - [my-frame (new frame% [label "Test Results"][width 300] [height 200])] - [my-editor (new editor-canvas% [editor my-text] [parent my-frame] - [style '(auto-hscroll auto-vscroll)])]) - (send my-text insert - (format "Recorded ~a check~a. ~a" - num-checks - (if (= 1 num-checks) "" "s") - (format "~a check~a failed." - num-failed-tests - (if (= 1 num-failed-tests) - "" - "s")))) - (unless (null? failed-check) - (send my-text insert "\n") - (for-each (lambda (f) (report-check-failure f my-text)) - (reverse failed-check)) - (send my-frame resize - (min (+ 300 (* 5 (send my-text line-end-position num-failed-tests #f))) 1000) - (min (+ 200 (* 5 num-failed-tests)) 1000))) - (send my-text move-position 'home) - (send my-text lock #t) - (send my-frame show #t))]) - #t)) - - (define (report-check-failure fail text) - (make-link text (check-fail-src fail)) - (send text insert "\n ") - (cond - [(unexpected-error? fail) - (send text insert "check encountered the following error instead of the expected value, ") - (insert-value text (unexpected-error-expected fail)) - (send text insert (format ". ~n :: ~a~n" (unexpected-error-message fail)))] - [(unequal? fail) - (send text insert "Actual value ") - (insert-value text (unequal-test fail)) - (send text insert " differs from ") - (insert-value text (unequal-actual fail)) - (send text insert ", the expected value.\n")] - [(outofrange? fail) - (send text insert "Actual value ") - (insert-value text (outofrange-test fail)) - (send text insert (format " is not within ~v of expected value " (outofrange-range fail))) - (insert-value text (outofrange-actual fail)) - (send text insert ".\n")] - [(incorrect-error? fail) - (send text insert - (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) - (send text insert "check-error expected the following error, but instead received the value ") - (insert-value text (expected-error-value fail)) - (send text insert (format ".~n ~a~n" (expected-error-message fail)))])) - - (define (insert-value text value) - (send text insert - (cond - [(is-a? value snip%) - (send value set-style (send (send text get-style-list) - find-named-style "Standard")) - 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) - (send text-snip set-style (send (send text get-style-list) - find-named-style "Standard")) - text-snip))] - [else (format "~v" value)]))) - - ;make-link: text% (listof (U string snip%)) src -> void - (define (make-link text dest) - (let ((start (send text get-end-position))) - (send text insert "check failed ") - (send text insert (format-src dest)) - (send text set-clickback - start (send text get-end-position) - (lambda (t s e) - (open-and-highlight-in-file dest)) - #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 (open-and-highlight-in-file srcloc) - ;; the code here did not work properly. Need tool-level integration to make this work. -robby - (void)) - - (define (format-src src) - (string-append (cond - ((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)))) - - - ) diff --git a/collects/lang/htdp-advanced.ss b/collects/lang/htdp-advanced.ss index b030ab2f3f..45af174122 100644 --- a/collects/lang/htdp-advanced.ss +++ b/collects/lang/htdp-advanced.ss @@ -8,6 +8,7 @@ mzlib/pretty syntax/docprovide scheme/promise + test-engine/scheme-tests "posn.ss") ;; syntax: @@ -60,4 +61,7 @@ (all-from-except intermediate: lang/htdp-intermediate-lambda procedures cons list* append) - (all-from advanced: lang/private/advanced-funs procedures))) + (all-from advanced: lang/private/advanced-funs procedures)) + + (provide (all-from-out test-engine/scheme-tests)) + ) diff --git a/collects/lang/htdp-beginner-abbr.ss b/collects/lang/htdp-beginner-abbr.ss index b013606fcd..06f83bc004 100644 --- a/collects/lang/htdp-beginner-abbr.ss +++ b/collects/lang/htdp-beginner-abbr.ss @@ -3,7 +3,8 @@ (require mzlib/etc mzlib/list mzlib/math - syntax/docprovide) + syntax/docprovide + test-engine/scheme-tests) ;; Implements the forms: (require "private/teach.ss" @@ -42,4 +43,7 @@ ;; procedures: (provide-and-document procedures - (all-from beginner: lang/htdp-beginner procedures))) + (all-from beginner: lang/htdp-beginner procedures)) + + (provide (all-from-out test-engine/scheme-tests)) + ) diff --git a/collects/lang/htdp-beginner.ss b/collects/lang/htdp-beginner.ss index 4eae5a98dc..158fb9cbbd 100644 --- a/collects/lang/htdp-beginner.ss +++ b/collects/lang/htdp-beginner.ss @@ -11,7 +11,8 @@ ;; Implements the forms: (require "private/teach.ss" - "private/contract-forms.ss") + "private/contract-forms.ss" + test-engine/scheme-tests) ;; syntax: (provide (rename-out @@ -89,4 +90,8 @@ (provide-and-document/wrap procedures in-rator-position-only - (all-from beginner: lang/private/beginner-funs procedures))) + (all-from beginner: lang/private/beginner-funs procedures)) + + (provide (all-from-out test-engine/scheme-tests)) + + ) diff --git a/collects/lang/htdp-intermediate-lambda.ss b/collects/lang/htdp-intermediate-lambda.ss index 00bf0a9a07..55e0c1d350 100644 --- a/collects/lang/htdp-intermediate-lambda.ss +++ b/collects/lang/htdp-intermediate-lambda.ss @@ -4,7 +4,8 @@ "private/contract-forms.ss" mzlib/etc mzlib/list - syntax/docprovide) + syntax/docprovide + test-engine/scheme-tests) ;; syntax: (provide (rename-out @@ -45,4 +46,6 @@ ;; procedures: (provide-and-document procedures - (all-from intermediate: lang/htdp-intermediate procedures))) + (all-from intermediate: lang/htdp-intermediate procedures)) + (provide (all-from-out test-engine/scheme-tests)) + ) diff --git a/collects/lang/htdp-intermediate.ss b/collects/lang/htdp-intermediate.ss index 0f3c00ab59..0f8255e8df 100644 --- a/collects/lang/htdp-intermediate.ss +++ b/collects/lang/htdp-intermediate.ss @@ -5,7 +5,8 @@ "private/contract-forms.ss" mzlib/etc mzlib/list - syntax/docprovide) + syntax/docprovide + test-engine/scheme-tests) ;; syntax: (provide (rename-out @@ -46,4 +47,6 @@ ;; procedures: (provide-and-document procedures - (all-from beginner: lang/private/intermediate-funs procedures))) + (all-from beginner: lang/private/intermediate-funs procedures)) + (provide (all-from-out test-engine/scheme-tests)) + ) diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index c1bb5fb723..593b957645 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -36,7 +36,10 @@ "stepper-language-interface.ss" "debugger-language-interface.ss" "run-teaching-program.ss" - stepper/private/shared) + stepper/private/shared + + (lib "scheme-gui.scm" "test-engine") + ) (provide tool@) @@ -154,18 +157,24 @@ (define/override (on-execute settings run-in-user-thread) (let ([drs-namespace (current-namespace)] [set-result-module-name - ((current-module-name-resolver) '(lib "lang/private/set-result.ss") #f #f)]) + ((current-module-name-resolver) '(lib "lang/private/set-result.ss") #f #f)] + [scheme-test-module-name + ((current-module-name-resolver) '(lib "test-engine/scheme-gui.scm") #f #f)]) (run-in-user-thread (lambda () (read-accept-quasiquote (get-accept-quasiquote?)) (namespace-attach-module drs-namespace ''drscheme-secrets) - (namespace-attach-module drs-namespace set-result-module-name) + (namespace-attach-module drs-namespace set-result-module-name) (error-display-handler teaching-languages-error-display-handler) (error-value->string-handler (λ (x y) (teaching-languages-error-value->string settings x y))) (current-eval (add-annotation (htdp-lang-settings-tracing? settings) (current-eval))) (error-print-source-location #f) (read-decimal-as-inexact #f) - (read-accept-dot (get-read-accept-dot))))) + (read-accept-dot (get-read-accept-dot)) + (namespace-attach-module drs-namespace scheme-test-module-name) + (namespace-require scheme-test-module-name) + (scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace)) + ))) (super on-execute settings run-in-user-thread)) (define/private (teaching-languages-error-value->string settings v len) @@ -888,10 +897,9 @@ ;; this inspector should be powerful enough to see ;; any structure defined in the user's namespace (define drscheme-inspector (current-inspector)) - (eval `(,#'module drscheme-secrets mzscheme - (provide drscheme-inspector) - (define drscheme-inspector ,drscheme-inspector))) + (provide drscheme-inspector) + (define drscheme-inspector ,drscheme-inspector))) (namespace-require ''drscheme-secrets) diff --git a/collects/lang/private/teachprims.ss b/collects/lang/private/teachprims.ss index 47d2de4b3c..8180eb8bf7 100644 --- a/collects/lang/private/teachprims.ss +++ b/collects/lang/private/teachprims.ss @@ -11,8 +11,8 @@ namespace. (module teachprims mzscheme (require "../imageeq.ss" - mzlib/list - mzlib/etc) + mzlib/list + mzlib/etc) (define-syntax (define-teach stx) (syntax-case stx () diff --git a/collects/lang/run-teaching-program.ss b/collects/lang/run-teaching-program.ss index c216a9f323..60e1adf5d6 100644 --- a/collects/lang/run-teaching-program.ss +++ b/collects/lang/run-teaching-program.ss @@ -56,7 +56,8 @@ #f `(,#'module ,module-name ,language-module ,@(map (λ (x) `(require ,x)) teachpacks) - ,@body-exps))) + ,@body-exps + ,@(if (null? body-exps) '() '((run-tests) (display-results)))))) rep)))] [(require) (set! state 'done-or-exn) @@ -121,14 +122,16 @@ [(#%provide specs ...) (loop (cdr bodies))] [else - (let ([new-exp - (with-syntax ([body body] - [print-results - (lambda results - (when rep - (send rep display-results/void results)))]) - (syntax - (call-with-values - (lambda () body) - print-results)))]) - (cons new-exp (loop (cdr bodies))))]))]))) + (if (syntax-property body 'test-call) + (cons body (loop (cdr bodies))) + (let ([new-exp + (with-syntax ([body body] + [print-results + (lambda results + (when rep + (send rep display-results/void results)))]) + (syntax + (call-with-values + (lambda () body) + print-results)))]) + (cons new-exp (loop (cdr bodies)))))]))]))) diff --git a/collects/profj/ast.ss b/collects/profj/ast.ss index 32abb951cc..3763893c4f 100644 --- a/collects/profj/ast.ss +++ b/collects/profj/ast.ss @@ -15,6 +15,9 @@ ;(make-src int int int int loc) (p-define-struct src (line col pos span file)) + (provide src->list) + (define (src->list src) + (list (src-file src) (src-line src) (src-col src) (src-pos src) (src-span src))) ;;(make-package (U #f name) (list import) (list (U class-def interface-def))) (p-define-struct package (name imports defs)) @@ -295,6 +298,9 @@ ;(make-check-expect (U #f type) src Expression Expression (U #f Expression) src) (p-define-struct (check-expect check) (test actual range ta-src)) + ;(make-check-rand (U #f type) src Expression Expression src) + (p-define-struct (check-rand check) (test range ta-src)) + ;(make-check-catch (U #f type) src Expression type-spec) (p-define-struct (check-catch check) (test exn)) diff --git a/collects/profj/check.ss b/collects/profj/check.ss index c062fe8632..ca7799feaa 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -2780,6 +2780,14 @@ level (expr-src exp) type-recs)) + ((check-rand? exp) + (check-test-rand (check-rand-test exp) + (check-rand-range exp) + check-sub-expr + env + level + (check-rand-ta-src exp) + type-recs)) ((check-mutate? exp) (check-test-mutate (check-mutate-mutate exp) (check-mutate-check exp) @@ -2904,7 +2912,47 @@ (unless (eq? (method-record-rtype meth) 'boolean) (check-by-error 'not-boolean test-type actual-type by src)) (set-check-by-compare! exp meth)))]) - (make-type/env 'boolean new-env)))]))) + (make-type/env 'boolean new-env)))]))) + + ;check-test-rand: exp exp (exp env -> type/env) env symbol src type-records -> type/env + (define (check-test-rand actual expt-range check-e env level src type-recs) + (let* ([actual-te (check-e actual env)] + [actual-t (type/env-t actual-te)] + [expt-range-te (check-e expt-range (type/env-e actual-te))] + [er-t (type/env-t expt-range-te)] + [res (make-type/env 'boolean (type/env-e expt-range-te))]) + (when (eq? actual-t 'void) + (check-rand-type-error 'void level actual-t er-t (expr-src actual))) + (when (eq? er-t 'void) + (check-rand-type-error 'void level actual-t er-t (expr-src expt-range))) + (when (not (array-type? er-t)) + (check-rand-type-error 'not-array level actual-t er-t (expr-src expt-range))) + (let ([er-a-t + (cond + [(eq? (array-type-dim er-t) 1) (array-type-type er-t)] + [else (make-array-type (array-type-type er-t) (sub1 (array-type-dim er-t)))])]) + (cond + ((and (eq? 'boolean actual-t) + (eq? 'boolean er-a-t)) res) + ((and (prim-numeric-type? actual-t) + (prim-numeric-type? er-a-t)) + res) + ((and (memq level '(advanced full)) + (reference-type? actual-t) (reference-type? er-a-t)) + (cond + ((castable? er-a-t actual-t type-recs) res) + (else (check-rand-type-error 'cast level actual-t er-a-t src)))) + ((and (memq level '(advanced full)) + (or (array-type? actual-t) (array-type? er-a-t))) + (cond + ((castable? er-a-t actual-t type-recs) res) + (else + (check-rand-type-error 'cast level actual-t er-a-t src)))) + (else + (check-rand-type-error (if (memq level '(advanced full)) 'cast 'subtype) + level + actual-t er-a-t src)))))) + ;check-test-mutate: exp exp (exp env -> type/env) env src type-records -> type/env (define (check-test-mutate mutatee check check-sub-expr env src type-recs) @@ -3673,6 +3721,24 @@ )))) 'check ta-src )) + + (define (check-rand-type-error kind level actual-type expt-type src) + (raise-error + 'check + (cond + [(and (eq? kind 'void) (eq? actual-type 'void)) + "The test of a 'check' expression must produce a value. Current expression does not."] + [(and (eq? kind 'void) (eq? expt-type 'void)) + "The expected result of a 'check' 'within' expression must be an array of values. Current expression is not a value."] + [(eq? kind 'not-array) + (string-append "The expected result of a 'check' 'within' expression must be an array of possible values.\n" + (format "Found ~a, which is not appropriate in this expression." (type->ext-name expt-type)))] + [else + (string-append "A 'check' 'within' expession compares the test expression with an array of possible answers.\n" + (format "Found an array of ~a which is not comparable to ~a." + (type->ext-name expt-type) + (type->ext-name actual-type)))]) + 'within src)) (define (check-by-==-error t-type a-type src) (raise-error diff --git a/collects/profj/info.ss b/collects/profj/info.ss index 8defd0b225..b959874d91 100644 --- a/collects/profj/info.ss +++ b/collects/profj/info.ss @@ -2,8 +2,8 @@ (require string-constants) (define name "ProfessorJ") -(define tools (list (list "tool.ss") (list "test-tool.ss"))) -(define tool-names '("ProfessorJ" "ProfessorJ Testing")) +(define tools (list (list "tool.ss") #;(list "test-tool.ss"))) +(define tool-names '("ProfessorJ" #;"ProfessorJ Testing")) (define install-collection "installer.ss") (define pre-install-collection "pre-installer.ss") (define textbook-pls diff --git a/collects/profj/libs/java/runtime.scm b/collects/profj/libs/java/runtime.scm index 97a933172e..4affe8aa71 100644 --- a/collects/profj/libs/java/runtime.scm +++ b/collects/profj/libs/java/runtime.scm @@ -14,11 +14,13 @@ (lib "ArithmeticException.ss" "profj" "libs" "java" "lang") (lib "ClassCastException.ss" "profj" "libs" "java" "lang") (lib "NullPointerException.ss" "profj" "libs" "java" "lang") + (prefix ast: (lib "ast.ss" "profj")) ) (provide convert-to-string shift not-equal bitwise mod divide-dynamic divide-int divide-float and or cast-primitive cast-reference instanceof-array nullError - check-eq? dynamic-equal? compare compare-within check-catch check-mutate check-by) + check-eq? dynamic-equal? compare compare-within check-catch check-mutate check-by + compare-rand) (define (check-eq? obj1 obj2) (or (eq? obj1 obj2) @@ -210,9 +212,50 @@ ;(make-exn-thrown exn boolean string) (define-struct exn-thrown (exception expected? cause)) + (define (java-equal? v1 v2 visited-v1 visited-v2 range use-range?) + (or (eq? v1 v2) + (already-seen? v1 v2 visited-v1 visited-v2) + (cond + ((and (number? v1) (number? v2)) + (if (or (inexact? v1) (inexact? v2) use-range?) + (<= (abs (- v1 v2)) range) + (= v1 v2))) + ((and (object? v1) (object? v2)) + (cond + ((equal? "String" (send v1 my-name)) + (and (equal? "String" (send v2 my-name)) + (equal? (send v1 get-mzscheme-string) (send v2 get-mzscheme-string)))) + ((equal? "array" (send v1 my-name)) + (and (equal? "array" (send v2 my-name)) + (= (send v1 length) (send v2 length)) + (let ((v1-vals (array->list v1)) + (v2-vals (array->list v2))) + (andmap (lambda (x) x) + (map (lambda (v1i v2i v1-valsi v2-valsi) + (java-equal? v1i v2i v1-valsi v2-valsi range use-range?)) + v1-vals v2-vals + (map (lambda (v) (cons v1 visited-v1)) v1-vals) + (map (lambda (v) (cons v2 visited-v2)) v2-vals) + ))))) + (else + (and (equal? (send v1 my-name) (send v2 my-name)) + (let ((v1-fields (send v1 field-values)) + (v2-fields (send v2 field-values))) + (and (= (length v1-fields) (length v2-fields)) + (andmap (lambda (x) x) + (map + (lambda (v1-f v2-f v1-fvs v2-fvs) + (java-equal? v1-f v2-f v1-fvs v2-fvs range use-range?)) + v1-fields v2-fields + (map (lambda (v) (cons v1 visited-v1)) v1-fields) + (map (lambda (v) (cons v2 visited-v2)) v2-fields))))))))) + ((and (not (object? v1)) (not (object? v2))) (equal? v1 v2)) + (else #f)))) + + ;compare-within: (-> val) val val (list symbol string) (U #f object) boolean . boolean -> boolean (define (compare-within test act range info src test-obj catch? . within?) - (letrec ((java-equal? + (letrec (#;(java-equal? (lambda (v1 v2 visited-v1 visited-v2) (or (eq? v1 v2) (already-seen? v1 v2 visited-v1 visited-v2) @@ -253,7 +296,7 @@ (set! fail? #t) (list exception catch? e "eval"))]) (test))) - (let ([res (if fail? #f (java-equal? test act null null))] + (let ([res (if fail? #f (java-equal? test act null null range (not (null? within?))))] [values-list (append (list act test) (if (null? within?) (list range) null))]) (if (in-check-mutate?) (stored-checks (cons (list res 'check-expect info values-list src) (stored-checks))) @@ -297,6 +340,27 @@ (stored-checks (cons (list (and (not fail?) result) 'check-by info values-list src) (stored-checks))) (report-check-result (and (not fail?) result) 'check-by info values-list src test-obj)) (and (not fail?) result))) + + ;compare-rand: (-> val) value [list string] src object -> boolean + (define (compare-rand test range info src test-obj) + (let* ([fail? #f] + [test-val (with-handlers ((exn? + (lambda (e) + (set! fail? #t) + (list exception e)))) + (test))] + [expected-vals (array->list range)] + [result + (and (not fail?) + (ormap (lambda (e-v) (java-equal? test-val e-v null null 0.001 #t)) + expected-vals))] + [res-list (list range test-val)]) + (if + (in-check-mutate?) + (stored-checks (cons (list (and (not fail?) result) 'check-rand info res-list src test-obj) + (stored-checks))) + (report-check-result (and (not fail?) result) 'check-rand info res-list src test-obj)) + (and (not fail?) result))) ;check-mutate: (-> val) (-> boolean) (list string) src object -> boolean (define (check-mutate mutatee check info src test-obj) @@ -348,6 +412,7 @@ (expected-format (case check-kind ((check-expect check-by) "to produce ") + ((check-rand) "to produce one of ") ((check-catch) "to throw an instance of ")))) (cond [(not (eq? 'check-by check-kind)) @@ -367,6 +432,14 @@ (list", instead an error occurred")] [else (list ", instead found " (second formatted-values))]))) + ((check-rand) + (cond + [(and eval-exception-raised? (not exception-not-error?)) + (list ", instead a " (second formatted-values) " exception occurred")] + [(and eval-exception-raised? exception-not-error?) + (list", instead an error occurred")] + [else + (list ", instead found " (second formatted-values))])) ((check-catch) (if (= (length formatted-values) 1) (list ", instead no exceptions occurred") diff --git a/collects/profj/libs/java/tester/TestBase.djava b/collects/profj/libs/java/tester/TestBase.djava index bc3bc7dd69..d8863d4b13 100644 --- a/collects/profj/libs/java/tester/TestBase.djava +++ b/collects/profj/libs/java/tester/TestBase.djava @@ -13,8 +13,19 @@ public final class TestBase { } // void || (listof (list string (listof string (listof int)))) - dynamic testCoverage( boolean getResult, int src) { +// dynamic testCoverage( boolean getResult, int src) { +// return null; +// } + + dynamic testedClasses() { return null; } + + dynamic testedMethods( dynamic cl ) { + return false; + } + dynamic testedMethodsSrcs( dynamic cl ) { + return false; + } } \ No newline at end of file diff --git a/collects/profj/parsers/full-parser.ss b/collects/profj/parsers/full-parser.ss index 75858fcbfb..ff9f569ec4 100644 --- a/collects/profj/parsers/full-parser.ss +++ b/collects/profj/parsers/full-parser.ss @@ -1027,6 +1027,8 @@ (make-check-expect #f (build-src 4) $2 $4 #f (build-src 2 4))] [(check ConditionalExpression expect ConditionalExpression within ConditionalExpression) (make-check-expect #f (build-src 6) $2 $4 $6 (build-src 2 4))] + [(check ConditionalExpression within ConditionalExpression) + (make-check-rand #f (build-src 4) $2 $4 (build-src 2 4))] [(check ConditionalExpression catch Type) (make-check-catch #f (build-src 4) $2 $4)] [(check ConditionalExpression expect ConditionalExpression by ==) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index fb46a743a3..d0b32d1b46 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -6,7 +6,9 @@ "parameters.ss" mzlib/class mzlib/list - mzlib/etc) + mzlib/etc + (prefix int-set: (lib "integer-set.ss")) + ) (provide translate-program translate-interactions (struct compilation-unit (contains code locations depends))) @@ -736,14 +738,28 @@ (filter (lambda (m) (and (method? m) (method-src m))) (def-members d)))) class-defs)) - (class/lookup-funcs + (tested-methods + (map (lambda (c/m) + (cons (car c/m) + (map (lambda (m) (id-string (method-name m))) (cdr c/m)))) + class/methods-list)) + (tested-methods-expr-srcs + (map (lambda (c/m) + (cons (car c/m) + (map + (lambda (m) + (let ([srcs (get-srcs (method-body m))]) + (srcs->spans srcs))) + (cdr c/m)))) + class/methods-list)) + #;(class/lookup-funcs (map (lambda (c) (let* ((m-name (lambda (m) (id-string (method-name m)))) (m-start (lambda (m) (src-pos (method-src m)))) (m-stop (lambda (m) (+ (m-start m) (src-span (method-src m)))))) `(let ((methods-covered ',(map (lambda (m) `(,(m-name m) #f)) - (cdr c))) + (cdr c))) (srcs ',(map (lambda (m) `(,(m-name m) ,(get-srcs (method-body m)))) (cdr c)))) @@ -761,7 +777,16 @@ (set-cdr! (assq ,(m-name m) methods-covered) (list #t))))))) (cdr c)))))))) class/methods-list))) - (list `(define/override (testCoverage-boolean-int report? src) + (list + `(define/override (testedClasses) + (append (list ,@test-classes) (super testedClasses))) + `(define/override (testedMethods-dynamic class-name) + (or (assq class-name (list ,@tested-methods)) + (super testedMethods-dynamic class-name))) + `(define/override (testMethodsSrcs-dynamic class-name) + (or (assq class-name (list ,@tested-methods-expr-srcs)) + (super testedMethodsSrcs-dynamic class-name))) + #;`(define/override (testCoverage-boolean-int report? src) (let ((class/lookups (list ,@class/lookup-funcs))) (if report? (append (map (lambda (c) (list (car c) (cadr c))) @@ -1308,32 +1333,32 @@ extends)) (define (get-srcs stmt) - (cond - [(ifS? stmt) - (append (get-expr-srcs (ifS-cond stmt)) - (get-srcs (ifS-then stmt)) - (get-srcs (ifS-else stmt)))] - [(throw? stmt) - (get-expr-srcs (throw-expr stmt))] - [(return? stmt) - (get-expr-srcs (return-expr stmt))] - [(while? stmt) - (append (get-expr-srcs (while-cond stmt)) - (get-srcs (while-loop stmt)))] - [(doS? stmt) - (append (get-srcs (doS-loop stmt)) - (get-expr-srcs (doS-cond stmt)))] - [(for? stmt) - (get-srcs (for-loop stmt))] - [(try? stmt) - (append (get-srcs (try-body stmt)) - (apply append - (map (compose get-srcs catch-body) (try-catches stmt)))) - ] - [(block? stmt) - (apply append (map get-srcs (block-stmts stmt)))] - [(statement-expression? stmt) (get-expr-srcs stmt)] - [else null])) + (cond + [(ifS? stmt) + (append (get-expr-srcs (ifS-cond stmt)) + (get-srcs (ifS-then stmt)) + (get-srcs (ifS-else stmt)))] + [(throw? stmt) + (get-expr-srcs (throw-expr stmt))] + [(return? stmt) + (get-expr-srcs (return-expr stmt))] + [(while? stmt) + (append (get-expr-srcs (while-cond stmt)) + (get-srcs (while-loop stmt)))] + [(doS? stmt) + (append (get-srcs (doS-loop stmt)) + (get-expr-srcs (doS-cond stmt)))] + [(for? stmt) + (get-srcs (for-loop stmt))] + [(try? stmt) + (append (get-srcs (try-body stmt)) + (apply append + (map (compose get-srcs catch-body) (try-catches stmt)))) + ] + [(block? stmt) + (apply append (map get-srcs (block-stmts stmt)))] + [(statement-expression? stmt) (get-expr-srcs stmt)] + [else null])) (define (get-expr-srcs expr) (cond @@ -1391,6 +1416,13 @@ (get-expr-srcs (assignment-right expr)))) (else (list (src-pos (expr-src expr)))))) + (define (srcs->spans srcs) + (cond + [(null? srcs) (int-set:make-range)] + [else (int-set:union (int-set:make-range (src-pos (car srcs)) + (+ (src-pos (car srcs)) (src-span (car srcs)))) + (srcs->spans (cdr srcs)))])) + ;translate-interface: interface-def type-records-> (list syntax) (define (translate-interface iface type-recs) (let* ((header (def-header iface)) @@ -2200,12 +2232,12 @@ (define (translate-expression expr) (let ((translated-expr (translate-expression-unannotated expr))) - (if (and (not (to-file)) (coverage?) (expr-src expr)) + (if (and (not (to-file)) (coverage?) (not (check? expr)) (expr-src expr)) (make-syntax #f `(begin0 ,translated-expr (cond ((namespace-variable-value 'current~test~object% #f (lambda () #f)) => (lambda (test) - (send test covered-position ,(expr-src expr)))))) + (send test analyze-position (quote ,(src->list (expr-src expr)))))))) #f) translated-expr))) @@ -2999,6 +3031,9 @@ (check-expect-actual expr) (check-expect-range expr) (expr-src expr))) + ((check-rand? expr) (translate-check-rand (check-rand-test expr) + (check-rand-range expr) + (expr-src expr))) ((check-catch? expr) (translate-check-catch (check-catch-test expr) (check-catch-exn expr) (expr-src expr))) @@ -3020,18 +3055,31 @@ (make-syntax #f `(,(if (not range) 'javaRuntime:compare 'javaRuntime:compare-within) ,@(if range (list t a r) (list t a)) - ,extracted-info ,src + ,extracted-info (quote ,(src->list src)) (namespace-variable-value 'current~test~object% #f (lambda () #f)) ,(testcase-ext?)) (build-src src)))) + ;translate-check-rand: expression expression src -> syntax + (define (translate-check-rand test range src) + (let ([t (make-syntax #f `(lambda () ,(translate-expression test)) #f)] + [r (translate-expression range)] + [extracted-info (checked-info test)]) + (make-syntax #f + `(javaRuntime:compare-rand ,t ,r ,extracted-info (quote ,(src->list src)) + (namespace-variable-value 'current~test~object% #f + (lambda () #f)) + ) + (build-src src)))) + ;translate-check-catch: expression type-spec src -> syntax (define (translate-check-catch test catch src) (let ((t (create-syntax #f `(lambda () ,(translate-expression test)) #f)) (n (get-class-name catch))) (make-syntax #f - `(javaRuntime:check-catch ,t ,(symbol->string (syntax-object->datum n)) ,n ,(checked-info test) ,src + `(javaRuntime:check-catch ,t ,(symbol->string (syntax-object->datum n)) ,n ,(checked-info test) + (quote ,(src->list src)) (namespace-variable-value 'current~test~object% #f (lambda () #f))) (build-src src)))) @@ -3055,7 +3103,7 @@ 'eq?) ,info ,(if (method-record? comp) (method-record-name comp) "==") - ,src + (quote ,(src->list src)) (namespace-variable-value 'current~test~object% #f (lambda () #f))) (build-src src)))) @@ -3064,7 +3112,7 @@ (let ((t (create-syntax #f `(lambda () ,(translate-expression mutatee)) #f)) (c (create-syntax #f `(lambda () ,(translate-expression check)) #f))) (make-syntax #f - `(javaRuntime:check-mutate ,t ,c ,(checked-info mutatee) ,src + `(javaRuntime:check-mutate ,t ,c ,(checked-info mutatee) (quote ,(src->list src)) (namespace-variable-value 'current~test~object% #f (lambda () #f))) (build-src src)))) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index eac93d30f7..e8cf71af57 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -11,7 +11,9 @@ profj/libs/java/lang/Object profj/libs/java/lang/array profj/libs/java/lang/String) (require "compile.ss" "parameters.ss" "parsers/lexer.ss" "parser.ss" - (except-in "ast.ss" for) "tester.scm" + (lib "java-tests.scm" "test-engine") + (lib "test-coverage.scm" "test-engine") + (except-in "ast.ss" for) #;"tester.scm" "display-java.ss") (require (for-syntax scheme/base @@ -758,6 +760,21 @@ (define/private (syntax-as-top s) (if (syntax? s) (namespace-syntax-introduce s) s)) + (define/private (get-program-windows rep source) + (let* ([dr-frame (send rep get-top-level-window)] + [tabs (and dr-frame + (send dr-frame get-tabs))] + [tab/defs (if dr-frame + (map (lambda (t) (cons (send t get-defs) t)) tabs) + null)] + [tab/def (filter (lambda (t/d) + (and (is-a? (car t/d) drscheme:unit:definitions-text<%>) + (send (car t/d) port-name-matches? source))) + tab/defs)]) + (and dr-frame + (= 1 (length tab/def)) + (list dr-frame (car (car tab/def)) (cdr (car tab/def)))))) + (define/public (on-execute settings run-in-user-thread) (dynamic-require 'profj/libs/java/lang/Object #f) (let ([obj-path ((current-module-name-resolver) 'profj/libs/java/lang/Object #f #f)] @@ -769,7 +786,6 @@ (test-ext? (profj-settings-allow-check? settings)) (testcase-ext? (profj-settings-allow-test? settings)) (let ((execute-types (create-type-record))) - (read-case-sensitive #t) (run-in-user-thread (lambda () (test-ext? (profj-settings-allow-check? settings)) @@ -803,14 +819,28 @@ ((and (not require?) (null? mods) tests-run? (null? extras)) (void)) ((and (not require?) (null? mods) (not tests-run?)) (when (tests?) - (let ((tc (make-object test-info%))) - (namespace-set-variable-value! 'current~test~object% tc) - (let ((objs (send tc run-tests - (map (lambda (c) - (list c (old-current-eval (string->symbol c)))) - (car examples)) - (cadr examples)))) - (let inner-loop ((os objs)) + (let* ([test-engine-obj + (make-object (if (testcase-ext?) java-test-base% java-examples-engine%))] + [tc-info (send test-engine-obj get-info)]) + (namespace-set-variable-value! 'current~test~object% tc-info) + (send test-engine-obj install-tests + (map (lambda (c) + (list c (old-current-eval (string->symbol c)) c)) + (car examples))) + (when (coverage?) + (send (send test-engine-obj get-info) add-analysis + (make-object coverage-analysis%))) + (send test-engine-obj refine-display-class + (cond + [(and (testcase-ext?) (coverage?)) java-test-coverage-graphics%] + [(coverage?) java-examples-coverage-graphics%] + [(testcase-ext?) java-test-graphics%] + [else java-examples-graphics%])) + (send test-engine-obj run) + (send test-engine-obj setup-display (drscheme:rep:current-rep) e) + (send test-engine-obj summarize-results (current-output-port)) + (let ([test-objs (send test-engine-obj test-objects)]) + (let inner-loop ((os test-objs)) (unless (null? os) (let ((formatted (format-java-value (car os) (make-format-style #t 'field #f)))) @@ -822,16 +852,7 @@ (write-special (car out)) (loop (cdr out)))) (newline)) - (inner-loop (cdr os)))) - (parameterize ([current-eventspace e]) - (queue-callback - (lambda () - (let* ((tab (and (is-a? src drscheme:unit:definitions-text<%>) - (send src get-tab))) - (frame (and tab (send tab get-frame))) - (test-window - (make-object test-display% frame tab))) - (send test-window pop-up-window tc)))))))) + (inner-loop (cdr os))))))) (set! tests-run? #t) (loop mods extras require?)) ((and (not require?) (null? mods) tests-run?) diff --git a/collects/test-engine/info.ss b/collects/test-engine/info.ss new file mode 100644 index 0000000000..f4c3bf1284 --- /dev/null +++ b/collects/test-engine/info.ss @@ -0,0 +1,5 @@ +(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 diff --git a/collects/test-engine/java-tests.scm b/collects/test-engine/java-tests.scm new file mode 100644 index 0000000000..9bf68d7f2d --- /dev/null +++ b/collects/test-engine/java-tests.scm @@ -0,0 +1,349 @@ +(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)))) + (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%))) + + (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 diff --git a/collects/test-engine/scheme-gui.scm b/collects/test-engine/scheme-gui.scm new file mode 100644 index 0000000000..4c9a0a3558 --- /dev/null +++ b/collects/test-engine/scheme-gui.scm @@ -0,0 +1,34 @@ +(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 diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss new file mode 100644 index 0000000000..c46b80289d --- /dev/null +++ b/collects/test-engine/scheme-tests.ss @@ -0,0 +1,276 @@ +(module scheme-tests 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 ) + + ) + + (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)))) + + (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 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 new file mode 100644 index 0000000000..5c0918b5a0 --- /dev/null +++ b/collects/test-engine/test-coverage.scm @@ -0,0 +1,142 @@ +(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 diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm new file mode 100644 index 0000000000..20290858d1 --- /dev/null +++ b/collects/test-engine/test-display.scm @@ -0,0 +1,381 @@ +(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%)))) + + (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 + [(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-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")) + + ;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))))) + + (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"] + [(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 " (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 diff --git a/collects/test-engine/test-engine.scm b/collects/test-engine/test-engine.scm new file mode 100644 index 0000000000..dbc98c815e --- /dev/null +++ b/collects/test-engine/test-engine.scm @@ -0,0 +1,62 @@ +(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 diff --git a/collects/test-engine/test-info.scm b/collects/test-engine/test-info.scm new file mode 100644 index 0000000000..748d81c07a --- /dev/null +++ b/collects/test-engine/test-info.scm @@ -0,0 +1,64 @@ +(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) + + (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 diff --git a/collects/test-engine/test-tool.scm b/collects/test-engine/test-tool.scm new file mode 100644 index 0000000000..5eb40b6947 --- /dev/null +++ b/collects/test-engine/test-tool.scm @@ -0,0 +1,174 @@ +(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) + + (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-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) + + )) + + )