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

Merging testing branch (kathyg/test-harnessv4-2) onto trunk: -r8903:9138

Browse Source 
svn: r9160
This commit is contained in:
Kathy Gray 2008-04-04 11:30:36 +00:00
parent efd1a91cd0
commit 7a6dff6d19
26 changed files with 1837 additions and 375 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

282
collects/htdp/testing.ss
View File

@ -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 <expression> <expression>)
check-within ;; syntax : (check-within <expression> <expression> <expression>)
check-error ;; syntax : (check-error <expression> <expression>)
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))))
)

6
collects/lang/htdp-advanced.ss
View File

@ -8,6 +8,7 @@
mzlib/pretty mzlib/pretty
syntax/docprovide syntax/docprovide
scheme/promise scheme/promise
test-engine/scheme-tests
"posn.ss") "posn.ss")
;; syntax: ;; syntax:
@ -60,4 +61,7 @@
(all-from-except intermediate: lang/htdp-intermediate-lambda procedures (all-from-except intermediate: lang/htdp-intermediate-lambda procedures
cons list* append) 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))
)

8
collects/lang/htdp-beginner-abbr.ss
View File

@ -3,7 +3,8 @@
(require mzlib/etc (require mzlib/etc
mzlib/list mzlib/list
mzlib/math mzlib/math
syntax/docprovide) syntax/docprovide
test-engine/scheme-tests)
;; Implements the forms: ;; Implements the forms:
(require "private/teach.ss" (require "private/teach.ss"
@ -42,4 +43,7 @@
;; procedures: ;; procedures:
(provide-and-document (provide-and-document
procedures procedures
(all-from beginner: lang/htdp-beginner procedures))) (all-from beginner: lang/htdp-beginner procedures))
(provide (all-from-out test-engine/scheme-tests))
)

9
collects/lang/htdp-beginner.ss
View File

@ -11,7 +11,8 @@
;; Implements the forms: ;; Implements the forms:
(require "private/teach.ss" (require "private/teach.ss"
"private/contract-forms.ss") "private/contract-forms.ss"
test-engine/scheme-tests)
;; syntax: ;; syntax:
(provide (rename-out (provide (rename-out
@ -89,4 +90,8 @@
(provide-and-document/wrap (provide-and-document/wrap
procedures procedures
in-rator-position-only 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))
)

7
collects/lang/htdp-intermediate-lambda.ss
View File

@ -4,7 +4,8 @@
"private/contract-forms.ss" "private/contract-forms.ss"
mzlib/etc mzlib/etc
mzlib/list mzlib/list
syntax/docprovide) syntax/docprovide
test-engine/scheme-tests)
;; syntax: ;; syntax:
(provide (rename-out (provide (rename-out
@ -45,4 +46,6 @@
;; procedures: ;; procedures:
(provide-and-document (provide-and-document
procedures procedures
(all-from intermediate: lang/htdp-intermediate procedures))) (all-from intermediate: lang/htdp-intermediate procedures))
(provide (all-from-out test-engine/scheme-tests))
)

7
collects/lang/htdp-intermediate.ss
View File

@ -5,7 +5,8 @@
"private/contract-forms.ss" "private/contract-forms.ss"
mzlib/etc mzlib/etc
mzlib/list mzlib/list
syntax/docprovide) syntax/docprovide
test-engine/scheme-tests)
;; syntax: ;; syntax:
(provide (rename-out (provide (rename-out
@ -46,4 +47,6 @@
;; procedures: ;; procedures:
(provide-and-document (provide-and-document
procedures 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))
)

22
collects/lang/htdp-langs.ss
View File

@ -36,7 +36,10 @@
"stepper-language-interface.ss" "stepper-language-interface.ss"
"debugger-language-interface.ss" "debugger-language-interface.ss"
"run-teaching-program.ss" "run-teaching-program.ss"
stepper/private/shared) stepper/private/shared
(lib "scheme-gui.scm" "test-engine")
)
(provide tool@) (provide tool@)
@ -154,18 +157,24 @@
(define/override (on-execute settings run-in-user-thread) (define/override (on-execute settings run-in-user-thread)
(let ([drs-namespace (current-namespace)] (let ([drs-namespace (current-namespace)]
[set-result-module-name [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 (run-in-user-thread
(lambda () (lambda ()
(read-accept-quasiquote (get-accept-quasiquote?)) (read-accept-quasiquote (get-accept-quasiquote?))
(namespace-attach-module drs-namespace ''drscheme-secrets) (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-display-handler teaching-languages-error-display-handler)
(error-value->string-handler (λ (x y) (teaching-languages-error-value->string settings x y))) (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))) (current-eval (add-annotation (htdp-lang-settings-tracing? settings) (current-eval)))
(error-print-source-location #f) (error-print-source-location #f)
(read-decimal-as-inexact #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)) (super on-execute settings run-in-user-thread))
(define/private (teaching-languages-error-value->string settings v len) (define/private (teaching-languages-error-value->string settings v len)
@ -888,10 +897,9 @@
;; this inspector should be powerful enough to see ;; this inspector should be powerful enough to see
;; any structure defined in the user's namespace ;; any structure defined in the user's namespace
(define drscheme-inspector (current-inspector)) (define drscheme-inspector (current-inspector))
(eval `(,#'module drscheme-secrets mzscheme (eval `(,#'module drscheme-secrets mzscheme
(provide drscheme-inspector) (provide drscheme-inspector)
(define drscheme-inspector ,drscheme-inspector))) (define drscheme-inspector ,drscheme-inspector)))
(namespace-require ''drscheme-secrets) (namespace-require ''drscheme-secrets)

4
collects/lang/private/teachprims.ss
View File

@ -11,8 +11,8 @@ namespace.
(module teachprims mzscheme (module teachprims mzscheme
(require "../imageeq.ss" (require "../imageeq.ss"
mzlib/list mzlib/list
mzlib/etc) mzlib/etc)
(define-syntax (define-teach stx) (define-syntax (define-teach stx)
(syntax-case stx () (syntax-case stx ()

27
collects/lang/run-teaching-program.ss
View File

@ -56,7 +56,8 @@
#f #f
`(,#'module ,module-name ,language-module `(,#'module ,module-name ,language-module
,@(map (λ (x) `(require ,x)) teachpacks) ,@(map (λ (x) `(require ,x)) teachpacks)
,@body-exps))) ,@body-exps
,@(if (null? body-exps) '() '((run-tests) (display-results))))))
rep)))] rep)))]
[(require) [(require)
(set! state 'done-or-exn) (set! state 'done-or-exn)
@ -121,14 +122,16 @@
[(#%provide specs ...) [(#%provide specs ...)
(loop (cdr bodies))] (loop (cdr bodies))]
[else [else
(let ([new-exp (if (syntax-property body 'test-call)
(with-syntax ([body body] (cons body (loop (cdr bodies)))
[print-results (let ([new-exp
(lambda results (with-syntax ([body body]
(when rep [print-results
(send rep display-results/void results)))]) (lambda results
(syntax (when rep
(call-with-values (send rep display-results/void results)))])
(lambda () body) (syntax
print-results)))]) (call-with-values
(cons new-exp (loop (cdr bodies))))]))]))) (lambda () body)
print-results)))])
(cons new-exp (loop (cdr bodies)))))]))])))

6
collects/profj/ast.ss
View File

@ -15,6 +15,9 @@
;(make-src int int int int loc) ;(make-src int int int int loc)
(p-define-struct src (line col pos span file)) (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))) ;;(make-package (U #f name) (list import) (list (U class-def interface-def)))
(p-define-struct package (name imports defs)) (p-define-struct package (name imports defs))
@ -295,6 +298,9 @@
;(make-check-expect (U #f type) src Expression Expression (U #f Expression) src) ;(make-check-expect (U #f type) src Expression Expression (U #f Expression) src)
(p-define-struct (check-expect check) (test actual range ta-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) ;(make-check-catch (U #f type) src Expression type-spec)
(p-define-struct (check-catch check) (test exn)) (p-define-struct (check-catch check) (test exn))

68
collects/profj/check.ss
View File

@ -2780,6 +2780,14 @@
level level
(expr-src exp) (expr-src exp)
type-recs)) 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-mutate? exp)
(check-test-mutate (check-mutate-mutate exp) (check-test-mutate (check-mutate-mutate exp)
(check-mutate-check exp) (check-mutate-check exp)
@ -2904,7 +2912,47 @@
(unless (eq? (method-record-rtype meth) 'boolean) (unless (eq? (method-record-rtype meth) 'boolean)
(check-by-error 'not-boolean test-type actual-type by src)) (check-by-error 'not-boolean test-type actual-type by src))
(set-check-by-compare! exp meth)))]) (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 ;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) (define (check-test-mutate mutatee check check-sub-expr env src type-recs)
@ -3673,6 +3721,24 @@
)))) ))))
'check ta-src '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) (define (check-by-==-error t-type a-type src)
(raise-error (raise-error

4
collects/profj/info.ss
View File

@ -2,8 +2,8 @@
(require string-constants) (require string-constants)
(define name "ProfessorJ") (define name "ProfessorJ")
(define tools (list (list "tool.ss") (list "test-tool.ss"))) (define tools (list (list "tool.ss") #;(list "test-tool.ss")))
(define tool-names '("ProfessorJ" "ProfessorJ Testing")) (define tool-names '("ProfessorJ" #;"ProfessorJ Testing"))
(define install-collection "installer.ss") (define install-collection "installer.ss")
(define pre-install-collection "pre-installer.ss") (define pre-install-collection "pre-installer.ss")
(define textbook-pls (define textbook-pls

79
collects/profj/libs/java/runtime.scm
View File

@ -14,11 +14,13 @@
(lib "ArithmeticException.ss" "profj" "libs" "java" "lang") (lib "ArithmeticException.ss" "profj" "libs" "java" "lang")
(lib "ClassCastException.ss" "profj" "libs" "java" "lang") (lib "ClassCastException.ss" "profj" "libs" "java" "lang")
(lib "NullPointerException.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 (provide convert-to-string shift not-equal bitwise mod divide-dynamic divide-int
divide-float and or cast-primitive cast-reference instanceof-array nullError 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) (define (check-eq? obj1 obj2)
(or (eq? obj1 obj2) (or (eq? obj1 obj2)
@ -210,9 +212,50 @@
;(make-exn-thrown exn boolean string) ;(make-exn-thrown exn boolean string)
(define-struct exn-thrown (exception expected? cause)) (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 ;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?) (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) (lambda (v1 v2 visited-v1 visited-v2)
(or (eq? v1 v2) (or (eq? v1 v2)
(already-seen? v1 v2 visited-v1 visited-v2) (already-seen? v1 v2 visited-v1 visited-v2)
@ -253,7 +296,7 @@
(set! fail? #t) (set! fail? #t)
(list exception catch? e "eval"))]) (list exception catch? e "eval"))])
(test))) (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))]) [values-list (append (list act test) (if (null? within?) (list range) null))])
(if (in-check-mutate?) (if (in-check-mutate?)
(stored-checks (cons (list res 'check-expect info values-list src) (stored-checks))) (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))) (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)) (report-check-result (and (not fail?) result) 'check-by info values-list src test-obj))
(and (not fail?) result))) (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 ;check-mutate: (-> val) (-> boolean) (list string) src object -> boolean
(define (check-mutate mutatee check info src test-obj) (define (check-mutate mutatee check info src test-obj)
@ -348,6 +412,7 @@
(expected-format (expected-format
(case check-kind (case check-kind
((check-expect check-by) "to produce ") ((check-expect check-by) "to produce ")
((check-rand) "to produce one of ")
((check-catch) "to throw an instance of ")))) ((check-catch) "to throw an instance of "))))
(cond (cond
[(not (eq? 'check-by check-kind)) [(not (eq? 'check-by check-kind))
@ -367,6 +432,14 @@
(list", instead an error occurred")] (list", instead an error occurred")]
[else [else
(list ", instead found " (second formatted-values))]))) (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) ((check-catch)
(if (= (length formatted-values) 1) (if (= (length formatted-values) 1)
(list ", instead no exceptions occurred") (list ", instead no exceptions occurred")

13
collects/profj/libs/java/tester/TestBase.djava
View File

@ -13,8 +13,19 @@ public final class TestBase {
} }
// void || (listof (list string (listof string (listof int)))) // 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; return null;
} }
dynamic testedMethods( dynamic cl ) {
return false;
}
dynamic testedMethodsSrcs( dynamic cl ) {
return false;
}
} }

2
collects/profj/parsers/full-parser.ss
View File

@ -1027,6 +1027,8 @@
(make-check-expect #f (build-src 4) $2 $4 #f (build-src 2 4))] (make-check-expect #f (build-src 4) $2 $4 #f (build-src 2 4))]
[(check ConditionalExpression expect ConditionalExpression within ConditionalExpression) [(check ConditionalExpression expect ConditionalExpression within ConditionalExpression)
(make-check-expect #f (build-src 6) $2 $4 $6 (build-src 2 4))] (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) [(check ConditionalExpression catch Type)
(make-check-catch #f (build-src 4) $2 $4)] (make-check-catch #f (build-src 4) $2 $4)]
[(check ConditionalExpression expect ConditionalExpression by ==) [(check ConditionalExpression expect ConditionalExpression by ==)

120
collects/profj/to-scheme.ss
View File

@ -6,7 +6,9 @@
"parameters.ss" "parameters.ss"
mzlib/class mzlib/class
mzlib/list 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))) (provide translate-program translate-interactions (struct compilation-unit (contains code locations depends)))
@ -736,14 +738,28 @@
(filter (lambda (m) (filter (lambda (m)
(and (method? m) (method-src m))) (def-members d)))) (and (method? m) (method-src m))) (def-members d))))
class-defs)) 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) (map (lambda (c)
(let* ((m-name (lambda (m) (id-string (method-name m)))) (let* ((m-name (lambda (m) (id-string (method-name m))))
(m-start (lambda (m) (src-pos (method-src m)))) (m-start (lambda (m) (src-pos (method-src m))))
(m-stop (lambda (m) (m-stop (lambda (m)
(+ (m-start m) (src-span (method-src m)))))) (+ (m-start m) (src-span (method-src m))))))
`(let ((methods-covered ',(map (lambda (m) `(,(m-name m) #f)) `(let ((methods-covered ',(map (lambda (m) `(,(m-name m) #f))
(cdr c))) (cdr c)))
(srcs ',(map (lambda (m) (srcs ',(map (lambda (m)
`(,(m-name m) ,(get-srcs (method-body m)))) `(,(m-name m) ,(get-srcs (method-body m))))
(cdr c)))) (cdr c))))
@ -761,7 +777,16 @@
(set-cdr! (assq ,(m-name m) methods-covered) (list #t))))))) (set-cdr! (assq ,(m-name m) methods-covered) (list #t)))))))
(cdr c)))))))) (cdr c))))))))
class/methods-list))) 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))) (let ((class/lookups (list ,@class/lookup-funcs)))
(if report? (if report?
(append (map (lambda (c) (list (car c) (cadr c))) (append (map (lambda (c) (list (car c) (cadr c)))
@ -1308,32 +1333,32 @@
extends)) extends))
(define (get-srcs stmt) (define (get-srcs stmt)
(cond (cond
[(ifS? stmt) [(ifS? stmt)
(append (get-expr-srcs (ifS-cond stmt)) (append (get-expr-srcs (ifS-cond stmt))
(get-srcs (ifS-then stmt)) (get-srcs (ifS-then stmt))
(get-srcs (ifS-else stmt)))] (get-srcs (ifS-else stmt)))]
[(throw? stmt) [(throw? stmt)
(get-expr-srcs (throw-expr stmt))] (get-expr-srcs (throw-expr stmt))]
[(return? stmt) [(return? stmt)
(get-expr-srcs (return-expr stmt))] (get-expr-srcs (return-expr stmt))]
[(while? stmt) [(while? stmt)
(append (get-expr-srcs (while-cond stmt)) (append (get-expr-srcs (while-cond stmt))
(get-srcs (while-loop stmt)))] (get-srcs (while-loop stmt)))]
[(doS? stmt) [(doS? stmt)
(append (get-srcs (doS-loop stmt)) (append (get-srcs (doS-loop stmt))
(get-expr-srcs (doS-cond stmt)))] (get-expr-srcs (doS-cond stmt)))]
[(for? stmt) [(for? stmt)
(get-srcs (for-loop stmt))] (get-srcs (for-loop stmt))]
[(try? stmt) [(try? stmt)
(append (get-srcs (try-body stmt)) (append (get-srcs (try-body stmt))
(apply append (apply append
(map (compose get-srcs catch-body) (try-catches stmt)))) (map (compose get-srcs catch-body) (try-catches stmt))))
] ]
[(block? stmt) [(block? stmt)
(apply append (map get-srcs (block-stmts stmt)))] (apply append (map get-srcs (block-stmts stmt)))]
[(statement-expression? stmt) (get-expr-srcs stmt)] [(statement-expression? stmt) (get-expr-srcs stmt)]
[else null])) [else null]))
(define (get-expr-srcs expr) (define (get-expr-srcs expr)
(cond (cond
@ -1391,6 +1416,13 @@
(get-expr-srcs (assignment-right expr)))) (get-expr-srcs (assignment-right expr))))
(else (list (src-pos (expr-src 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) ;translate-interface: interface-def type-records-> (list syntax)
(define (translate-interface iface type-recs) (define (translate-interface iface type-recs)
(let* ((header (def-header iface)) (let* ((header (def-header iface))
@ -2200,12 +2232,12 @@
(define (translate-expression expr) (define (translate-expression expr)
(let ((translated-expr (translate-expression-unannotated 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 (make-syntax #f `(begin0 ,translated-expr
(cond (cond
((namespace-variable-value 'current~test~object% #f (lambda () #f)) ((namespace-variable-value 'current~test~object% #f (lambda () #f))
=> (lambda (test) => (lambda (test)
(send test covered-position ,(expr-src expr)))))) (send test analyze-position (quote ,(src->list (expr-src expr))))))))
#f) #f)
translated-expr))) translated-expr)))
@ -2999,6 +3031,9 @@
(check-expect-actual expr) (check-expect-actual expr)
(check-expect-range expr) (check-expect-range expr)
(expr-src 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? expr) (translate-check-catch (check-catch-test expr)
(check-catch-exn expr) (check-catch-exn expr)
(expr-src expr))) (expr-src expr)))
@ -3020,18 +3055,31 @@
(make-syntax #f (make-syntax #f
`(,(if (not range) 'javaRuntime:compare 'javaRuntime:compare-within) `(,(if (not range) 'javaRuntime:compare 'javaRuntime:compare-within)
,@(if range (list t a r) (list t a)) ,@(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 (namespace-variable-value 'current~test~object% #f
(lambda () #f)) (lambda () #f))
,(testcase-ext?)) ,(testcase-ext?))
(build-src src)))) (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 ;translate-check-catch: expression type-spec src -> syntax
(define (translate-check-catch test catch src) (define (translate-check-catch test catch src)
(let ((t (create-syntax #f `(lambda () ,(translate-expression test)) #f)) (let ((t (create-syntax #f `(lambda () ,(translate-expression test)) #f))
(n (get-class-name catch))) (n (get-class-name catch)))
(make-syntax #f (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 (namespace-variable-value 'current~test~object% #f
(lambda () #f))) (lambda () #f)))
(build-src src)))) (build-src src))))
@ -3055,7 +3103,7 @@
'eq?) 'eq?)
,info ,info
,(if (method-record? comp) (method-record-name comp) "==") ,(if (method-record? comp) (method-record-name comp) "==")
,src (quote ,(src->list src))
(namespace-variable-value 'current~test~object% #f (lambda () #f))) (namespace-variable-value 'current~test~object% #f (lambda () #f)))
(build-src src)))) (build-src src))))
@ -3064,7 +3112,7 @@
(let ((t (create-syntax #f `(lambda () ,(translate-expression mutatee)) #f)) (let ((t (create-syntax #f `(lambda () ,(translate-expression mutatee)) #f))
(c (create-syntax #f `(lambda () ,(translate-expression check)) #f))) (c (create-syntax #f `(lambda () ,(translate-expression check)) #f)))
(make-syntax #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 (namespace-variable-value 'current~test~object% #f
(lambda () #f))) (lambda () #f)))
(build-src src)))) (build-src src))))

61
collects/profj/tool.ss
View File

@ -11,7 +11,9 @@
profj/libs/java/lang/Object profj/libs/java/lang/array profj/libs/java/lang/Object profj/libs/java/lang/array
profj/libs/java/lang/String) profj/libs/java/lang/String)
(require "compile.ss" "parameters.ss" "parsers/lexer.ss" "parser.ss" (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") "display-java.ss")
(require (for-syntax scheme/base (require (for-syntax scheme/base
@ -758,6 +760,21 @@
(define/private (syntax-as-top s) (define/private (syntax-as-top s)
(if (syntax? s) (namespace-syntax-introduce s) 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) (define/public (on-execute settings run-in-user-thread)
(dynamic-require 'profj/libs/java/lang/Object #f) (dynamic-require 'profj/libs/java/lang/Object #f)
(let ([obj-path ((current-module-name-resolver) 'profj/libs/java/lang/Object #f #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)) (test-ext? (profj-settings-allow-check? settings))
(testcase-ext? (profj-settings-allow-test? settings)) (testcase-ext? (profj-settings-allow-test? settings))
(let ((execute-types (create-type-record))) (let ((execute-types (create-type-record)))
(read-case-sensitive #t)
(run-in-user-thread (run-in-user-thread
(lambda () (lambda ()
(test-ext? (profj-settings-allow-check? settings)) (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) tests-run? (null? extras)) (void))
((and (not require?) (null? mods) (not tests-run?)) ((and (not require?) (null? mods) (not tests-run?))
(when (tests?) (when (tests?)
(let ((tc (make-object test-info%))) (let* ([test-engine-obj
(namespace-set-variable-value! 'current~test~object% tc) (make-object (if (testcase-ext?) java-test-base% java-examples-engine%))]
(let ((objs (send tc run-tests [tc-info (send test-engine-obj get-info)])
(map (lambda (c) (namespace-set-variable-value! 'current~test~object% tc-info)
(list c (old-current-eval (string->symbol c)))) (send test-engine-obj install-tests
(car examples)) (map (lambda (c)
(cadr examples)))) (list c (old-current-eval (string->symbol c)) c))
(let inner-loop ((os objs)) (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) (unless (null? os)
(let ((formatted (let ((formatted
(format-java-value (car os) (make-format-style #t 'field #f)))) (format-java-value (car os) (make-format-style #t 'field #f))))
@ -822,16 +852,7 @@
(write-special (car out)) (write-special (car out))
(loop (cdr out)))) (loop (cdr out))))
(newline)) (newline))
(inner-loop (cdr os)))) (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))))))))
(set! tests-run? #t) (set! tests-run? #t)
(loop mods extras require?)) (loop mods extras require?))
((and (not require?) (null? mods) tests-run?) ((and (not require?) (null? mods) tests-run?)

5
collects/test-engine/info.ss Normal file
View File

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

349
collects/test-engine/java-tests.scm Normal file
View File

@ -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%)
)

34
collects/test-engine/scheme-gui.scm Normal file
View File

@ -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)
)

276
collects/test-engine/scheme-tests.ss Normal file
View File

@ -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 <expression> <expression>)
check-within ;; syntax : (check-within <expression> <expression> <expression>)
check-error ;; syntax : (check-error <expression> <expression>)
)
(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)]))
)

142
collects/test-engine/test-coverage.scm Normal file
View File

@ -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 ())
))
)

381
collects/test-engine/test-display.scm Normal file
View File

@ -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%)
)

62
collects/test-engine/test-engine.scm Normal file
View File

@ -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%)
)

64
collects/test-engine/test-info.scm Normal file
View File

@ -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)))
))
)

174
collects/test-engine/test-tool.scm Normal file
View File

@ -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)
))
)