formatting, v4-isms, props, etc
svn: r9168
This commit is contained in:
Eli Barzilay
parent
a3d8cb9447
commit
22f506d718
|
|
@ -1,5 +1,4 @@
|
|||
(module info setup/infotab
|
||||
(define name "Test Engine")
|
||||
#lang setup/infotab
|
||||
|
||||
(define tools (list (list "test-tool.scm")))
|
||||
(define tool-names '("Test Engine"))
|
||||
)
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
(module java-tests scheme/base
|
||||
#lang scheme/base
|
||||
|
||||
(require scheme/class
|
||||
(lib "etc.ss")
|
||||
(lib "display-java.ss" "profj"))
|
||||
(require "test-engine.scm"
|
||||
mzlib/etc
|
||||
profj/display-java
|
||||
"test-engine.scm"
|
||||
"test-display.scm"
|
||||
"test-info.scm"
|
||||
"test-coverage.scm")
|
||||
|
|
@ -29,11 +29,9 @@
|
|||
(define/public (test-objects) test-objs)
|
||||
|
||||
(define/augment (run)
|
||||
(for-each (lambda (t) (initialize-test t)) tests)
|
||||
(for ([t tests]) (initialize-test t))
|
||||
(inner (void) run)
|
||||
(for-each (lambda (t) (run-test t)) tests))
|
||||
|
||||
))
|
||||
(for ([t tests]) (run-test t)))))
|
||||
|
||||
(define (java-test test-info-class)
|
||||
(class* (java-test-maker test-info-class 'test-basic) ()
|
||||
|
|
@ -45,24 +43,23 @@
|
|||
(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
|
||||
;; need to run constructor
|
||||
(send test-info add-test-class test-name test-src)
|
||||
(let ([test-obj (make-object test-class)])
|
||||
(set! test-objs (cons test-obj test-objs))
|
||||
(for-each (lambda (tc) (run-testcase tc))
|
||||
(send test-obj testMethods))
|
||||
(for ([tc (send test-obj testMethods)]) (run-testcase tc))
|
||||
(let ([tested-classes (send test-obj testedClasses)])
|
||||
(send test-info add-tests-info tested-classes
|
||||
(map (lambda (c) (send test-obj testedMethods c)) tested-classes)
|
||||
(map (lambda (c) (send test-obj testedMethodsSrcs c)) tested-classes))))
|
||||
(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)))
|
||||
|
||||
))
|
||||
;; 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) ()
|
||||
|
|
@ -79,21 +76,21 @@
|
|||
(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-obj
|
||||
#,(string->symbol (string-append test-name
|
||||
"-constructor")))))
|
||||
(for ([tc (build-testcases test-obj)]) (run-testcase tc))
|
||||
(send test-info complete-test))))
|
||||
|
||||
(define/private (build-testcases object)
|
||||
(let ([methods (reverse (interface->method-names (object-interface object)))])
|
||||
(map (lambda (m) (list m
|
||||
(lambda () ((current-eval) #`(send #,object #,m)))
|
||||
#f))
|
||||
(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))
|
||||
(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
|
||||
|
|
@ -107,20 +104,14 @@
|
|||
(and (test-method-name? name) (no-args? name)))
|
||||
|
||||
(define (test-method-name? name)
|
||||
(regexp-match "^test" (symbol->string name)))
|
||||
(regexp-match? #rx"^test" (symbol->string name)))
|
||||
|
||||
(define (no-args? name)
|
||||
(not (regexp-match "-" (symbol->string name))))
|
||||
(not (regexp-match? #rx"-" (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))))
|
||||
|
||||
|
||||
))
|
||||
(let ([n (symbol->string name)])
|
||||
(regexp-match? "^(?:tst|tet|Test|tes)" n)))))
|
||||
|
||||
(define-struct test-stat (name src tests cases) #:mutable)
|
||||
(define-struct tests-data (c-name methods method-srcs))
|
||||
|
|
@ -141,7 +132,8 @@
|
|||
|
||||
(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)))
|
||||
(map make-tests-data
|
||||
tests test-methods test-method-srcs)))
|
||||
|
||||
(define/pubment (complete-test)
|
||||
(set! test-class-stats (cons current-test test-class-stats))
|
||||
|
|
@ -166,23 +158,24 @@
|
|||
(when current-testcase
|
||||
(set-testcase-stat-checks!
|
||||
current-testcase
|
||||
(cons (make-failed-check src msg) (testcase-stat-checks current-testcase))))
|
||||
(cons (make-failed-check src msg)
|
||||
(testcase-stat-checks current-testcase))))
|
||||
(inner (void) check-failed msg src))
|
||||
|
||||
(define/public (format-value value)
|
||||
(make-java-snip value (make-format-style #t 'field #f)))
|
||||
|
||||
(super-instantiate ())
|
||||
|
||||
))
|
||||
(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 (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)
|
||||
|
||||
|
|
@ -194,16 +187,18 @@
|
|||
(inherit-field analyses)
|
||||
|
||||
(define/augment (add-test-class name src)
|
||||
(for-each (lambda (a) (send a register-test name src)) analyses)
|
||||
(for ([a analyses]) (send a register-test name src))
|
||||
(inner (void) add-test-class name src))
|
||||
(define/augment (complete-test)
|
||||
(for-each (lambda (a) (send a de-register-test (test-stat-src (get-current-test)))) analyses)
|
||||
(for ([a analyses])
|
||||
(send a de-register-test (test-stat-src (get-current-test))))
|
||||
(inner (void) complete-test))
|
||||
(define/augment (add-testcase name src)
|
||||
(for-each (lambda (a) (send a register-testcase name src)) analyses)
|
||||
(for ([a analyses]) (send a register-testcase name src))
|
||||
(inner (void) add-testcase name src))
|
||||
(define/augment (complete-testcase pass?)
|
||||
(for-each (lambda (a) (send a de-register-testcase (testcase-stat-src (get-current-testcase)))) analyses)
|
||||
(for ([a analyses])
|
||||
(send a de-register-testcase (testcase-stat-src (get-current-testcase))))
|
||||
(inner (void) complete-testcase pass?))
|
||||
|
||||
(super-instantiate ())))
|
||||
|
|
@ -225,49 +220,46 @@
|
|||
(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")))
|
||||
(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)
|
||||
)
|
||||
(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
|
||||
(format "Ran the following ~a:\n" (send this test-name)))
|
||||
(for ([test (send test-info get-test-results)])
|
||||
(send editor insert "\n")
|
||||
(send this insert-test-name editor test src-editor)
|
||||
(unless (null? (test-stat-cases test))
|
||||
(let* ([run-tests (reverse (test-stat-cases test))]
|
||||
[num-tests (length run-tests)]
|
||||
[failed-tests (filter (compose not testcase-stat-pass?) run-tests)])
|
||||
[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)))
|
||||
(send editor insert
|
||||
(format "Ran ~a ~a." num-tests (send this testcase-name)))
|
||||
(next-line editor)
|
||||
(send editor insert
|
||||
(if (null? failed-tests)
|
||||
(send editor insert (format "All ~a passed!" (send this testcase-name)))
|
||||
(send editor insert (format "~a of ~a ~a failed:"
|
||||
(format "All ~a passed!" (send this testcase-name))
|
||||
(format "~a of ~a ~a failed:"
|
||||
(length failed-tests) num-tests
|
||||
(send this testcase-name))))
|
||||
(next-line editor)
|
||||
(for-each
|
||||
(lambda (testcase)
|
||||
(for ([testcase run-tests])
|
||||
(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)])
|
||||
(if (null? (testcase-stat-checks testcase))
|
||||
(send editor insert "All checks succeeded!\n")
|
||||
(send this display-check-failures
|
||||
(testcase-stat-checks testcase)
|
||||
editor test-info src-editor))
|
||||
(next-line editor))
|
||||
run-tests)
|
||||
(inner (void) insert-tests editor test-info src-editor))))
|
||||
(send test-info get-test-results)
|
||||
))
|
||||
))
|
||||
(inner (void) insert-tests editor test-info src-editor)))))))
|
||||
|
||||
(define java-examples-display%
|
||||
(class* java-test-display% ()
|
||||
|
|
@ -280,10 +272,9 @@
|
|||
(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))
|
||||
))
|
||||
(for ([name (send test-info close-tests)])
|
||||
(send editor insert (format "\t~a\n" name))))
|
||||
(inner (void) insert-tests editor test-info src-editor))))
|
||||
|
||||
(define (java-coverage-display-mixin parent)
|
||||
(class* parent ()
|
||||
|
|
@ -302,20 +293,21 @@
|
|||
(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)
|
||||
(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)
|
||||
(for ([tested (test-stat-tests test-stat)])
|
||||
(unless (send coverage-info covers-spans
|
||||
(tests-data-method-srcs tested))
|
||||
(send editor insert
|
||||
(format-uncovered-message (test-stat-name test-stat)
|
||||
(tests-data-c-name tested)))
|
||||
(for-each (lambda (sub sub-span)
|
||||
(for ([sub (tests-data-methods tested)]
|
||||
[sub-span (tests-data-method-srcs tested)])
|
||||
(send editor insert
|
||||
(if (send coverage-info covers-span sub-span)
|
||||
(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))
|
||||
(format-covered-sub sub)
|
||||
(format-uncovered-sub sub))))))
|
||||
(inner (void) insert-test-name editor test-stat src-editor))
|
||||
|
||||
(define (format-uncovered-message test tests)
|
||||
|
|
@ -327,23 +319,28 @@
|
|||
|
||||
|
||||
(define/augride (insert-testcase-name editor testcase-stat src-editor)
|
||||
(insert-covered-button editor coverage-info (testcase-stat-src testcase-stat) src-editor #t))
|
||||
(insert-covered-button editor coverage-info
|
||||
(testcase-stat-src testcase-stat)
|
||||
src-editor #t))
|
||||
|
||||
(super-instantiate ())))
|
||||
|
||||
(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-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-engine%
|
||||
(java-examples (analyzed-test-mixin% java-examples-info%)))
|
||||
(define java-examples-graphics% java-examples-display%)
|
||||
(define java-examples-coverage-graphics% (java-coverage-display-mixin
|
||||
(test-coverage-button-mixin
|
||||
java-examples-display%)))
|
||||
(define 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%)
|
||||
|
||||
)
|
||||
(provide java-test-base%
|
||||
java-test-graphics%
|
||||
java-test-coverage-graphics%
|
||||
java-examples-engine%
|
||||
java-examples-graphics%
|
||||
java-examples-coverage-graphics%)
|
||||
|
|
|
|||
|
|
@ -1,13 +1,12 @@
|
|||
(module scheme-gui scheme/base
|
||||
#lang scheme/base
|
||||
|
||||
(require scheme/class)
|
||||
(require "test-engine.scm")
|
||||
(require scheme/class
|
||||
"test-engine.scm")
|
||||
|
||||
(define scheme-test-data (make-parameter (list #f #f)))
|
||||
|
||||
(define scheme-test%
|
||||
(class* test-engine% ()
|
||||
|
||||
(super-instantiate ())
|
||||
(inherit-field test-info test-display)
|
||||
(inherit setup-info)
|
||||
|
|
@ -23,12 +22,10 @@
|
|||
|
||||
(define/augment (run)
|
||||
(inner (void) run)
|
||||
(for-each (lambda (t) (run-test t)) (reverse tests)))
|
||||
(for ([t (reverse tests)]) (run-test t)))
|
||||
|
||||
(define/augment (run-test test) (test)
|
||||
(inner (void) run-test test))
|
||||
|
||||
))
|
||||
(define/augment (run-test test)
|
||||
(test)
|
||||
(inner (void) run-test test))))
|
||||
|
||||
(provide scheme-test% scheme-test-data)
|
||||
)
|
||||
|
|
@ -1,29 +1,26 @@
|
|||
(module scheme-tests mzscheme
|
||||
#lang mzscheme
|
||||
|
||||
(require (lib "teachprims.ss" "lang" "private")
|
||||
(require lang/private/teachprims
|
||||
mred
|
||||
framework
|
||||
mzlib/pretty
|
||||
mzlib/pconvert
|
||||
mzlib/class)
|
||||
|
||||
(require "scheme-gui.scm"
|
||||
mzlib/class
|
||||
"scheme-gui.scm"
|
||||
"test-display.scm")
|
||||
|
||||
(require-for-syntax (lib "shared.ss" "stepper" "private"))
|
||||
(require-for-syntax stepper/private/shared)
|
||||
|
||||
(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 ()
|
||||
(define (builder)
|
||||
(let ([te (build-test-engine)])
|
||||
(namespace-set-variable-value! 'test~object te (current-namespace))
|
||||
te)))
|
||||
te))
|
||||
|
||||
(define (test)
|
||||
(run-tests)
|
||||
|
|
@ -35,34 +32,37 @@
|
|||
|
||||
(define-syntax (run-tests stx)
|
||||
(syntax-case stx ()
|
||||
((_)
|
||||
[(_)
|
||||
(syntax-property
|
||||
#'(run (namespace-variable-value 'test~object #f builder (current-namespace)))
|
||||
'test-call #t))))
|
||||
#'(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))])
|
||||
#'(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 setup-display
|
||||
(car display-data) (cadr display-data))
|
||||
(send test-info summarize-results (current-output-port)))))
|
||||
'test-call #t))))
|
||||
'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))])
|
||||
#'(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))))
|
||||
|
||||
'test-call #t)]))
|
||||
|
||||
(provide run-tests display-results test test-text)
|
||||
|
||||
|
|
@ -95,25 +95,26 @@
|
|||
|
||||
(define-struct check-fail (src))
|
||||
|
||||
;(make-unexpected-error src string)
|
||||
;; (make-unexpected-error src string)
|
||||
(define-struct (unexpected-error check-fail) (expected message))
|
||||
;(make-unequal src scheme-val scheme-val)
|
||||
;; (make-unequal src scheme-val scheme-val)
|
||||
(define-struct (unequal check-fail) (test actual))
|
||||
;(make-outofrange src scheme-val scheme-val inexact)
|
||||
;; (make-outofrange src scheme-val scheme-val inexact)
|
||||
(define-struct (outofrange check-fail) (test actual range))
|
||||
;(make-incorrect-error src string)
|
||||
;; (make-incorrect-error src string)
|
||||
(define-struct (incorrect-error check-fail) (expected message))
|
||||
;(make-expected-error src string scheme-val)
|
||||
;; (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)
|
||||
[(_ 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))])
|
||||
#`(let ([test-info (namespace-variable-value
|
||||
'test~object #f builder (current-namespace))])
|
||||
(when test-info
|
||||
(insert-test test-info
|
||||
(lambda ()
|
||||
|
|
@ -127,18 +128,18 @@
|
|||
(syntax-span stx)))
|
||||
test-info)))))
|
||||
`stepper-hint
|
||||
`comes-from-check-expect))))
|
||||
((_ test)
|
||||
`comes-from-check-expect)))]
|
||||
[(_ test)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(raise-syntax-error 'check-expect CHECK-EXPECT-STR stx))
|
||||
((_ test actual extra ...)
|
||||
(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 ...)
|
||||
(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))))
|
||||
(raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx)]))
|
||||
|
||||
;check-values-expected: (-> scheme-val) scheme-val src -> void
|
||||
;; check-values-expected: (-> scheme-val) scheme-val src -> void
|
||||
(define (check-values-expected test actual src test-info)
|
||||
(error-check (lambda (v) (if (number? v) (exact? v) #t))
|
||||
actual INEXACT-NUMBERS-FMT)
|
||||
|
|
@ -149,90 +150,101 @@
|
|||
|
||||
(define-syntax (check-within stx)
|
||||
(syntax-case stx ()
|
||||
((_ test actual within)
|
||||
[(_ 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))])
|
||||
(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
|
||||
(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)
|
||||
test-info)))))))]
|
||||
[(_ test actual)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(raise-syntax-error 'check-within CHECK-WITHIN-STR stx))
|
||||
((_ test)
|
||||
(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 ...)
|
||||
(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 ...)
|
||||
(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))))
|
||||
(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))
|
||||
(run-and-check beginner-equal~? make-outofrange test actual within src
|
||||
test-info))
|
||||
|
||||
(define-syntax (check-error stx)
|
||||
(syntax-case stx ()
|
||||
((_ test error)
|
||||
[(_ 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))])
|
||||
(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)
|
||||
(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)
|
||||
test-info)))))))]
|
||||
[(_ test)
|
||||
(not (eq? (syntax-local-context) 'expression))
|
||||
(raise-syntax-error 'check-error CHECK-ERROR-STR stx))
|
||||
((_ test ...)
|
||||
(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))))
|
||||
(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?
|
||||
(let ([result (with-handlers ([exn?
|
||||
(lambda (e)
|
||||
(or (equal? (exn-message e) error)
|
||||
(make-incorrect-error src error (exn-message e))))))
|
||||
(make-incorrect-error src error
|
||||
(exn-message e))))])
|
||||
(let ([test-val (test)])
|
||||
(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)))))
|
||||
(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
|
||||
;; 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)))))
|
||||
(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)))))
|
||||
(send (send test-info get-info) check-failed (check->message result)
|
||||
(check-fail-src result)))))
|
||||
|
||||
(define (check->message fail)
|
||||
(cond
|
||||
|
|
@ -254,7 +266,8 @@
|
|||
".\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)))]
|
||||
(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))
|
||||
|
|
@ -272,5 +285,3 @@
|
|||
(send text* lock #t)
|
||||
text-snip))]
|
||||
[else (format "~v" value)]))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
(module test-coverage mzscheme
|
||||
#lang mzscheme
|
||||
|
||||
(require (lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(prefix list: (lib "list.ss"))
|
||||
(lib "integer-set.ss"))
|
||||
(require mzlib/class
|
||||
mred
|
||||
framework
|
||||
(prefix list: mzlib/list)
|
||||
mzlib/integer-set)
|
||||
|
||||
(provide (all-defined))
|
||||
|
||||
|
|
@ -13,17 +13,22 @@
|
|||
|
||||
(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)
|
||||
;; interger-set
|
||||
(define covered (make-range))
|
||||
;; [hashtable-of scheme-val -> integer-set]
|
||||
(define covered-from-src (make-hash-table 'weak))
|
||||
;; (listof covered-from-src keys)
|
||||
(define current-coverage-srcs null)
|
||||
|
||||
(define/public (covered-position start span)
|
||||
(let ([new-range (make-range start (+ start span))])
|
||||
(set! covered (union covered new-range))
|
||||
(for-each (lambda (key covered-set)
|
||||
(hash-table-put! covered-from-src key (union covered-set new-range)))
|
||||
(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)))
|
||||
(map (lambda (key)
|
||||
(hash-table-get covered-from-src key (make-range)))
|
||||
current-coverage-srcs))))
|
||||
|
||||
(define/public (register-coverage-point src)
|
||||
|
|
@ -42,7 +47,8 @@
|
|||
(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))))
|
||||
(highlight-covered editor (hash-table-get covered-from-src coverage-point
|
||||
(make-range))))
|
||||
|
||||
|
||||
(define/private (highlight-covered editor int-set)
|
||||
|
|
@ -54,9 +60,10 @@
|
|||
(letrec ([color-buff
|
||||
(lambda ()
|
||||
(cond
|
||||
((or (send editor is-locked?) (send editor in-edit-sequence?))
|
||||
(queue-callback color-buff))
|
||||
(else
|
||||
[(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))
|
||||
|
|
@ -68,32 +75,29 @@
|
|||
(unless (null? positions)
|
||||
(send editor change-style covered-highlight
|
||||
(sub1 (caar positions))
|
||||
(sub1 (cdar positions)) #f)
|
||||
(sub1 (cdar positions))
|
||||
#f)
|
||||
(loop (cdr positions))))
|
||||
(send editor end-test-color))))])
|
||||
(queue-callback color-buff))))
|
||||
)
|
||||
)
|
||||
|
||||
(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)))
|
||||
(let* ([button-editor (new (editor:standard-style-list-mixin text%)
|
||||
[auto-wrap #t])]
|
||||
[snip (new editor-snip% (editor button-editor) (with-border? #t))]
|
||||
[start (send dest get-end-position)])
|
||||
(send snip set-style
|
||||
(send (send dest get-style-list) find-named-style "Standard"))
|
||||
(send button-editor insert
|
||||
(if partial?
|
||||
(send button-editor insert "Highlight covered expressions")
|
||||
(send button-editor insert "Highlight all covered expressions"))
|
||||
"Highlight covered expressions"
|
||||
"Highlight all covered expressions"))
|
||||
(send dest insert snip)
|
||||
(send button-editor set-clickback
|
||||
0
|
||||
(send button-editor set-clickback 0
|
||||
(send button-editor get-end-position)
|
||||
(cond
|
||||
[(and src-editor partial?)
|
||||
|
|
@ -104,12 +108,10 @@
|
|||
(send coverage display-coverage src-editor))]
|
||||
[else (lambda (t s e) (void))])
|
||||
#f #f)
|
||||
(let ((c (new style-delta%)))
|
||||
(let ([c (new style-delta%)])
|
||||
(send c set-delta-foreground "royalblue")
|
||||
(send dest change-style c start (sub1 (send dest get-end-position)) #f))
|
||||
))
|
||||
)
|
||||
)
|
||||
(send dest change-style c start (sub1 (send dest get-end-position))
|
||||
#f))))))
|
||||
|
||||
(define analysis<%>
|
||||
(interface ()
|
||||
|
|
@ -134,9 +136,4 @@
|
|||
(send coverage-info covered-position (list-ref src 3) (list-ref src 4)))
|
||||
|
||||
(define/public (provide-info) coverage-info)
|
||||
(super-instantiate ())
|
||||
))
|
||||
|
||||
|
||||
|
||||
)
|
||||
(super-instantiate ())))
|
||||
|
|
|
|||
|
|
@ -1,12 +1,11 @@
|
|||
(module test-display scheme/base
|
||||
#lang 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")
|
||||
mred
|
||||
framework
|
||||
string-constants
|
||||
"test-info.scm")
|
||||
|
||||
(define test-display%
|
||||
(class* object% ()
|
||||
|
|
@ -27,9 +26,9 @@
|
|||
(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%))))
|
||||
(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)
|
||||
|
|
@ -50,7 +49,10 @@
|
|||
(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)))
|
||||
(lambda ()
|
||||
(put-preferences '(profj:test-window:docked?)
|
||||
'(#f))
|
||||
#f)))
|
||||
(send drscheme-frame display-test-panel content)
|
||||
(send window show #t))))
|
||||
|
||||
|
|
@ -70,7 +72,8 @@
|
|||
(when (> total-tests 0)
|
||||
(send editor insert
|
||||
(cond
|
||||
[(and (zero? failed-tests) (= 1 total-tests)) "Test passed!\n\n"]
|
||||
[(and (zero? failed-tests) (= 1 total-tests))
|
||||
"Test passed!\n\n"]
|
||||
[(zero? failed-tests) "All tests passed!\n\n"]
|
||||
[(= failed-tests total-tests) "0 tests passed.\n"]
|
||||
[else "~a of the ~a tests failed.\n\n"]))))]
|
||||
|
|
@ -84,11 +87,12 @@
|
|||
(when (> total-checks 0)
|
||||
(send editor insert
|
||||
(cond
|
||||
[(and (zero? failed-checks) (= 1 total-checks)) "Check passed!\n\n"]
|
||||
[(and (zero? failed-checks) (= 1 total-checks))
|
||||
"Check passed!\n\n"]
|
||||
[(zero? failed-checks) "All checks passed!\n\n"]
|
||||
[(= failed-checks total-checks) "0 checks passed.\n"]
|
||||
[else
|
||||
(format "~a of the ~a checks failed.\n\n" failed-checks total-checks)]))))])
|
||||
[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")
|
||||
|
|
@ -103,40 +107,37 @@
|
|||
(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))
|
||||
))
|
||||
insert-test-results editor test-info src-editor))))
|
||||
|
||||
(define/public (display-check-failures checks editor test-info src-editor)
|
||||
(for-each
|
||||
(lambda (failed-check)
|
||||
(for ([failed-check (reverse checks)])
|
||||
(send editor insert "\t")
|
||||
(make-link editor
|
||||
(failed-check-msg failed-check)
|
||||
(failed-check-src failed-check)
|
||||
src-editor)
|
||||
(send editor insert "\n"))
|
||||
(reverse checks)))
|
||||
(send editor insert "\n")))
|
||||
|
||||
(define/public (next-line editor) (send editor insert "\n\t"))
|
||||
|
||||
;make-link: text% (listof (U string snip%)) src editor -> void
|
||||
;; make-link: text% (listof (U string snip%)) src editor -> void
|
||||
(define (make-link text msg dest src-editor)
|
||||
(for-each (lambda (m)
|
||||
(for ([m msg])
|
||||
(when (is-a? m snip%)
|
||||
(send m set-style (send (send text get-style-list)
|
||||
find-named-style "Standard")))
|
||||
(send text insert m)) msg)
|
||||
(send text insert m))
|
||||
(let ((start (send text get-end-position)))
|
||||
(send text insert (format-src dest))
|
||||
(send text set-clickback
|
||||
start (send text get-end-position)
|
||||
(lambda (t s e)
|
||||
(highlight-check-error dest src-editor))
|
||||
(lambda (t s e) (highlight-check-error dest src-editor))
|
||||
#f #f)
|
||||
(let ((end (send text get-end-position))
|
||||
(c (new style-delta%)))
|
||||
(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)
|
||||
(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))))
|
||||
|
|
@ -148,8 +149,8 @@
|
|||
(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 "))
|
||||
[(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)))))
|
||||
|
||||
|
|
@ -186,7 +187,8 @@
|
|||
(define content
|
||||
(make-object editor-canvas% this #f '(auto-vscroll)))
|
||||
|
||||
(define button-panel (make-object horizontal-panel% this
|
||||
(define button-panel
|
||||
(make-object horizontal-panel% this
|
||||
'() #t 0 0 0 0 '(right bottom) 0 0 #t #f))
|
||||
|
||||
(define buttons
|
||||
|
|
@ -211,11 +213,11 @@
|
|||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(send this show #f)
|
||||
(put-preferences '(profj:test-window:docked?) '(#t))
|
||||
(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))
|
||||
|
|
@ -225,8 +227,7 @@
|
|||
(define/public (update-closer thunk)
|
||||
(set! close-cleanup thunk))
|
||||
(define/public (update-disable thunk)
|
||||
(set! disable-func thunk))
|
||||
))
|
||||
(set! disable-func thunk))))
|
||||
|
||||
(define test-panel%
|
||||
(class* vertical-panel% ()
|
||||
|
|
@ -239,7 +240,7 @@
|
|||
(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)))
|
||||
(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)
|
||||
|
|
@ -258,15 +259,15 @@
|
|||
(lambda (b c)
|
||||
(when (eq? 'button (send c get-event-type))
|
||||
(hide)
|
||||
(send (send frame get-current-tab) update-test-preference #f))))
|
||||
(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)
|
||||
)))
|
||||
(send frame undock-tests))))
|
||||
|
||||
(define/public (update-editor e)
|
||||
(send content set-editor e))
|
||||
|
|
@ -276,10 +277,10 @@
|
|||
(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)))
|
||||
))
|
||||
(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% ()
|
||||
|
|
@ -303,14 +304,14 @@
|
|||
[test-outcomes
|
||||
(lambda (zero-message)
|
||||
(printf "~a"
|
||||
(cond
|
||||
[(zero? total-tests) zero-message]
|
||||
(cond [(zero? total-tests) zero-message]
|
||||
[(= 1 total-tests) "Ran 1 test.\n"]
|
||||
[else (format "Ran ~a tests.\n" total-tests)]))
|
||||
(when (> total-tests 0)
|
||||
(printf "~a"
|
||||
(cond
|
||||
[(and (zero? failed-tests) (= 1 total-tests)) "Test passed!\n\n"]
|
||||
[(and (zero? failed-tests) (= 1 total-tests))
|
||||
"Test passed!\n\n"]
|
||||
[(zero? failed-tests) "All tests passed!\n\n"]
|
||||
[(= failed-tests total-tests) "0 tests passed.\n"]
|
||||
[else "~a of the ~a tests failed.\n\n"]))))]
|
||||
|
|
@ -324,11 +325,12 @@
|
|||
(when (> total-checks 0)
|
||||
(printf "~a"
|
||||
(cond
|
||||
[(and (zero? failed-checks) (= 1 total-checks)) "Check passed!\n\n"]
|
||||
[(and (zero? failed-checks) (= 1 total-checks))
|
||||
"Check passed!\n\n"]
|
||||
[(zero? failed-checks) "All checks passed!\n\n"]
|
||||
[(= failed-checks total-checks) "0 checks passed.\n"]
|
||||
[else
|
||||
(format "~a of the ~a checks failed.\n\n" failed-checks total-checks)]))))])
|
||||
[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")
|
||||
|
|
@ -341,25 +343,22 @@
|
|||
[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))
|
||||
))
|
||||
(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)
|
||||
(for ([failed-check (reverse checks)])
|
||||
(printf "~a" "\t")
|
||||
(make-link (failed-check-msg failed-check)
|
||||
(failed-check-src failed-check)
|
||||
)
|
||||
(printf "~a" "\n"))
|
||||
(reverse checks)))
|
||||
(failed-check-src failed-check))
|
||||
(printf "~a" "\n")))
|
||||
|
||||
(define/public (next-line) (printf "~a" "\n\t"))
|
||||
|
||||
;make-link: (listof (U string snip%)) src -> void
|
||||
;; make-link: (listof (U string snip%)) src -> void
|
||||
(define (make-link msg dest)
|
||||
(for-each (lambda (m) (printf m)) msg)
|
||||
(for-each printf msg)
|
||||
(printf (format-src dest)))
|
||||
|
||||
(define (format-src src)
|
||||
|
|
@ -367,15 +366,13 @@
|
|||
[src-line cadr]
|
||||
[src-col caddr])
|
||||
(string-append
|
||||
(cond
|
||||
[(symbol? (src-file src)) (string-append " At ")]
|
||||
((path? (src-file src)) (string-append " In " (path->string (src-file src)) " at "))
|
||||
((is-a? (src-file src) editor<%>) " At "))
|
||||
(cond [(symbol? (src-file src)) " At "]
|
||||
[(path? (src-file src))
|
||||
(string-append " In " (path->string (src-file src)) " at ")]
|
||||
[(is-a? (src-file src) editor<%>) " At "])
|
||||
"line " (number->string (src-line src))
|
||||
" column " (number->string (src-col src)))))
|
||||
|
||||
(super-instantiate ())))
|
||||
|
||||
(provide test-panel% test-window% test-display% test-display-textual%)
|
||||
|
||||
)
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
(module test-engine scheme/base
|
||||
#lang scheme/base
|
||||
|
||||
(require scheme/class
|
||||
"test-info.scm"
|
||||
|
|
@ -37,7 +37,8 @@
|
|||
(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)])))
|
||||
[(mixed-results)
|
||||
(send this display-results display-rep display-event-space)])))
|
||||
|
||||
(define/public (display-success port)
|
||||
(fprintf port "All tests passed!~n"))
|
||||
|
|
@ -46,17 +47,19 @@
|
|||
(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])
|
||||
(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 (initialize-test test)
|
||||
(inner (void) initialize-test test))
|
||||
|
||||
(define/pubment (run-test test) (inner (void) run-test test))
|
||||
(define/pubment (run-test test)
|
||||
(inner (void) run-test test))
|
||||
|
||||
(define/pubment (run-testcase testcase) (inner (void) run-testcase testcase))))
|
||||
(define/pubment (run-testcase testcase)
|
||||
(inner (void) run-testcase testcase))))
|
||||
|
||||
(provide test-engine%)
|
||||
|
||||
)
|
||||
|
|
@ -1,15 +1,14 @@
|
|||
(module test-info scheme/base
|
||||
#lang scheme/base
|
||||
|
||||
(require scheme/class)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
;(make-failed-check src (listof (U string snip%)))
|
||||
;; (make-failed-check src (listof (U string snip%)))
|
||||
(define-struct failed-check (src msg))
|
||||
|
||||
(define test-info-base%
|
||||
(class* object% ()
|
||||
|
||||
(super-instantiate ())
|
||||
|
||||
(init-field (style 'check-base))
|
||||
|
|
@ -28,8 +27,7 @@
|
|||
(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]
|
||||
(cond [(and (zero? total-tsts) (zero? total-cks)) 'no-tests]
|
||||
[(and (zero? failed-cks) (zero? failed-tsts)) 'all-passed]
|
||||
[else 'mixed-results]))
|
||||
|
||||
|
|
@ -43,7 +41,7 @@
|
|||
(set! total-tsts (add1 total-tsts))
|
||||
(inner (void) add-test))
|
||||
|
||||
;check-failed: (list (U string snip%)) src -> void
|
||||
;; check-failed: (list (U string snip%)) src -> void
|
||||
(define/pubment (check-failed msg src)
|
||||
(set! failed-cks (add1 failed-cks))
|
||||
(set! failures (cons (make-failed-check src msg) failures))
|
||||
|
|
@ -56,9 +54,6 @@
|
|||
(define/public (add-analysis a) (set! analyses (cons a analyses)))
|
||||
|
||||
(define/public (analyze-position src . vals)
|
||||
(for-each (lambda (a) (send a analyze src vals)) analyses))
|
||||
(for ([a analyses]) (send a analyze src vals)))
|
||||
(define/public (extract-info pred?)
|
||||
(filter pred? (map (lambda (a) (send a provide-info)) analyses)))
|
||||
|
||||
))
|
||||
)
|
||||
(filter pred? (map (lambda (a) (send a provide-info)) analyses)))))
|
||||
|
|
|
|||
|
|
@ -1,20 +1,18 @@
|
|||
(module test-tool scheme/base
|
||||
#lang 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^)
|
||||
(unit (import drscheme:tool^) (export drscheme:tool-exports^)
|
||||
|
||||
(define (phase1) (void))
|
||||
(define (phase2) (void))
|
||||
|
||||
;Overriding interactions as the current-rep implementation
|
||||
;; 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)
|
||||
|
|
@ -25,9 +23,7 @@
|
|||
(send test-display display-settings dr-frame tab ed-def)
|
||||
(send test-display display-results))))
|
||||
|
||||
(super-instantiate ())
|
||||
)
|
||||
)
|
||||
(super-instantiate ())))
|
||||
|
||||
(define (test-definitions-text%-mixin %)
|
||||
(class* % ()
|
||||
|
|
@ -68,17 +64,16 @@
|
|||
|
||||
(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))
|
||||
))
|
||||
(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)
|
||||
|
||||
|
|
@ -89,15 +84,16 @@
|
|||
(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)))
|
||||
(for ([t test-windows]) (send t show #f))
|
||||
(let ([ed (send (get-current-tab) get-test-editor)])
|
||||
(when ed (display-test-panel ed))))
|
||||
(define/public (undock-tests)
|
||||
(send test-panel remove)
|
||||
(for-each (lambda (t) (send t show #t)) test-windows))
|
||||
(for ([t test-windows]) (send t show #t)))
|
||||
|
||||
(define/override (make-root-area-container cls parent)
|
||||
(let* ([outer-p (super make-root-area-container panel:vertical-dragable% parent)]
|
||||
(let* ([outer-p (super make-root-area-container
|
||||
panel:vertical-dragable% parent)]
|
||||
[louter-panel (make-object vertical-panel% outer-p)]
|
||||
[test-p (make-object test-panel% outer-p '(deleted))]
|
||||
[root (make-object cls louter-panel)])
|
||||
|
|
@ -107,24 +103,23 @@
|
|||
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)))
|
||||
(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)
|
||||
|
|
@ -146,10 +141,12 @@
|
|||
[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
|
||||
(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?))))
|
||||
(send language update-test-setting settings test?))])
|
||||
(preferences:set
|
||||
(drscheme:language-configuration:get-settings-preferences-symbol)
|
||||
next-setting)
|
||||
|
|
@ -170,5 +167,3 @@
|
|||
(drscheme:get/extend:extend-tab test-tab%-mixin)
|
||||
|
||||
))
|
||||
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user