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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

6
collects/profj/ast.ss
View File

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

68
collects/profj/check.ss
View File

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

4
collects/profj/info.ss
View File

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

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

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

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))))
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;
}
}

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))]
[(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 ==)

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

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

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/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?)

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