Added string-constants for test-engine menu items.
Moved Enable/disable to language-X menu, and updated docs Sending old test window support to the 'attic' svn: r9824
This commit is contained in:
Kathy Gray
parent
211be167b7
commit
488bbd3829
|
|
@ -1,5 +0,0 @@
|
|||
(module test-tool mzscheme
|
||||
|
||||
(require "tester.scm")
|
||||
|
||||
(provide (rename test-tool@ tool@)))
|
||||
|
|
@ -1,729 +0,0 @@
|
|||
(module tester mzscheme
|
||||
|
||||
(require mred
|
||||
(lib "tool.ss" "drscheme")
|
||||
(prefix u: mzlib/unit)
|
||||
framework
|
||||
string-constants
|
||||
mzlib/class
|
||||
mzlib/list
|
||||
mzlib/file
|
||||
mzlib/etc)
|
||||
|
||||
(require "ast.ss" "display-java.ss" "parameters.ss")
|
||||
|
||||
(provide test-info% test-display% test-tool@)
|
||||
|
||||
; # *##$ *#*
|
||||
; # # #* # #
|
||||
; ##### $##$ *###$# ##### :## ##*##* @##### &##& *#*
|
||||
; # $ -$ #$ -# # # #+ *# # &+ +& -+$#
|
||||
; # ###### *###$ # ###### # # # # # # +$&:
|
||||
; # $ +# # # # # # # # *#*
|
||||
; #* :$ +* # *# #* :$ # # # # &+ +& # #
|
||||
; *##$ +##$+ @*###* *##$ ##### ### ### :##### &##& *#*
|
||||
|
||||
|
||||
#;(make-single-test string (listof testcase) (listof string)
|
||||
int (listof failed-check) (listof src))
|
||||
(define-struct single-test (name testcases not-tested
|
||||
num-checks failed-checks covered-exprs
|
||||
covered-methods))
|
||||
|
||||
;(make-failed-check src (listof (U string snip%)) (listof src))
|
||||
(define-struct failed-check (src msg covers))
|
||||
|
||||
;(make-testcase string boolean (listof src))
|
||||
(define-struct testcase (name passed? covers))
|
||||
|
||||
(define-local-member-name provide-test-results provide-covered)
|
||||
|
||||
(define test-info%
|
||||
(class* object% ()
|
||||
|
||||
(define tested-classes null);------ (listof single-test)
|
||||
(define covered null);------------- (listof src)
|
||||
(define nearly-tested-classes null);(listof string)
|
||||
|
||||
(define current-class (make-single-test "" null null 0 null null null))
|
||||
(define current-testcoverage null)
|
||||
|
||||
(define total-tests 0)
|
||||
(define failed-tests 0)
|
||||
(define total-checks 0)
|
||||
(define failed-checks 0)
|
||||
|
||||
(define current-test-obj null)
|
||||
|
||||
(define/public (add-check)
|
||||
(set-single-test-num-checks! current-class
|
||||
(add1 (single-test-num-checks current-class)))
|
||||
(set! total-checks (add1 total-checks)))
|
||||
|
||||
;check-failed: (list (U string snip%)) src -> void
|
||||
(define/public (check-failed msg src)
|
||||
(set-single-test-failed-checks! current-class
|
||||
(cons
|
||||
(make-failed-check src msg null)
|
||||
(single-test-failed-checks current-class)))
|
||||
(set! failed-checks (add1 failed-checks)))
|
||||
|
||||
(define/public (format-value value)
|
||||
(make-java-snip value (make-format-style #t 'field #f)))
|
||||
|
||||
(define/public (covered-position src)
|
||||
(set! covered (cons src covered))
|
||||
(set! current-testcoverage (cons src current-testcoverage))
|
||||
(set-single-test-covered-exprs!
|
||||
current-class
|
||||
(cons src (single-test-covered-exprs current-class)))
|
||||
(when (and (testcase-ext?) src (not (null? current-test-obj)))
|
||||
(send current-test-obj testCoverage-boolean-int #f (src-pos src))))
|
||||
|
||||
(define/public (provide-test-results)
|
||||
(values tested-classes covered nearly-tested-classes total-tests
|
||||
failed-tests total-checks failed-checks))
|
||||
|
||||
(define/public (provide-covered) covered)
|
||||
|
||||
;run-tests: (listof (list string class)) (listof string) -> (listof object)
|
||||
(define/public (run-tests tests close-names)
|
||||
(let ((objects
|
||||
(map
|
||||
(lambda (name/class)
|
||||
(set! current-class (make-single-test (car name/class) null null 0 null null null))
|
||||
(let ((obj (make-object (cadr name/class))))
|
||||
(when (testcase-ext?) (set! current-test-obj obj))
|
||||
(with-handlers ((exn? (lambda (e) (raise e))))
|
||||
((current-eval)
|
||||
#`(send #,obj #,(string->symbol (string-append (car name/class)
|
||||
"-constructor")))))
|
||||
(if (testcase-ext?)
|
||||
(run-testcases obj)
|
||||
(run-methods obj))
|
||||
(set! tested-classes (cons current-class tested-classes))
|
||||
(when (testcase-ext?)
|
||||
(set-single-test-covered-methods! current-class (send obj testCoverage-boolean-int #t 1)))
|
||||
(list (car name/class) obj)))
|
||||
tests)))
|
||||
(set! nearly-tested-classes close-names)
|
||||
(map cadr objects)))
|
||||
|
||||
(define/private (run-testcases object)
|
||||
(let loop ([methods (send object testMethods)])
|
||||
(cond
|
||||
[(null? methods) (void)]
|
||||
[else
|
||||
(set! total-tests (add1 total-tests))
|
||||
(set! current-testcoverage null)
|
||||
(let ((res ((cadr (car methods)))))
|
||||
(set-single-test-testcases!
|
||||
current-class
|
||||
(cons (make-testcase (car (car methods)) res current-testcoverage)
|
||||
(single-test-testcases current-class)))
|
||||
(unless res (set! failed-tests (add1 failed-tests))))
|
||||
(loop (cdr methods))])))
|
||||
|
||||
(define/private (run-methods object)
|
||||
(let loop ([methods (reverse (interface->method-names (object-interface object)))])
|
||||
(cond
|
||||
((null? methods) (void))
|
||||
((test-method? (car methods))
|
||||
(set! total-tests (add1 total-tests))
|
||||
(set! current-testcoverage null)
|
||||
(let ((res ((current-eval)
|
||||
#`(send #,object #,(car methods)))))
|
||||
(set-single-test-testcases!
|
||||
current-class
|
||||
(cons (make-testcase (car methods) res current-testcoverage)
|
||||
(single-test-testcases current-class)))
|
||||
(unless res (set! failed-tests (add1 failed-tests))))
|
||||
(loop (cdr methods)))
|
||||
((test-method-name? (car methods))
|
||||
(set-single-test-not-tested!
|
||||
current-class
|
||||
(cons (format "Method ~a could not run due to requiring arguments."
|
||||
(car methods))
|
||||
(single-test-not-tested current-class)))
|
||||
(loop (cdr methods)))
|
||||
((close-to-test-name? (car methods))
|
||||
(set-single-test-not-tested!
|
||||
current-class
|
||||
(cons (format "Method ~a has a name similar to a test, but does not begin with 'test'."
|
||||
(car methods))
|
||||
(single-test-not-tested current-class)))
|
||||
(loop (cdr methods)))
|
||||
(else (loop (cdr methods))))))
|
||||
|
||||
(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))))
|
||||
|
||||
(super-instantiate ())
|
||||
))
|
||||
|
||||
; ## # ## *#*
|
||||
; # # # # # #
|
||||
; ##### $##$ *###$# ##### $#@ # :## *###$# ##:#@ # $@#$: ##: :## *#*
|
||||
; # $ -$ #$ -# # $+ +# # #$ -# #* -$ # -# -$ $ -+$#
|
||||
; # ###### *###$ # ###### # # # *###$ # # # $##$# $- *$ +$&:
|
||||
; # $ +# # # # # +# # # # @+ # @ @ *#*
|
||||
; #* :$ +* # *# #* :$ $+ +# # # *# #: -$ # #- +# $$$ # #
|
||||
; *##$ +##$+ @*###* *##$ $#@ ## ##### @*###* # #@ ##### *##$ ## # *#*
|
||||
; # ++
|
||||
; ### ###
|
||||
|
||||
(define test-display%
|
||||
(class object% ()
|
||||
|
||||
(init-field (drscheme-frame #f))
|
||||
(init-field (current-tab #f))
|
||||
|
||||
(define/public (pop-up-window test-results)
|
||||
(when (and drscheme-frame current-tab)
|
||||
(let* ((curr-win (send current-tab get-test-window))
|
||||
(window
|
||||
(if curr-win
|
||||
curr-win
|
||||
(make-object test-window%)))
|
||||
(content (make-object (editor:standard-style-list-mixin text%))))
|
||||
(fill-in content test-results)
|
||||
(send content lock #t)
|
||||
(send window update-editor content)
|
||||
(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 (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/private (fill-in editor test-results)
|
||||
(let-values (((tested-classes covered nearly-tested-classes total-tests
|
||||
failed-tests total-checks failed-checks)
|
||||
(send test-results provide-test-results)))
|
||||
(letrec ((insert-content
|
||||
(lambda (source nextline?)
|
||||
(let loop ((contents source))
|
||||
(unless (null? contents)
|
||||
(send editor insert (car contents))
|
||||
(when nextline? (next-line))
|
||||
(loop (cdr contents))))))
|
||||
(next-line (lambda ()
|
||||
(send editor insert "\n "))))
|
||||
|
||||
(unless (= 0 total-tests)
|
||||
(send editor insert (format "Ran ~a total tests\n" total-tests))
|
||||
(if (= 0 failed-tests)
|
||||
(send editor insert "All tests passed!\n\n")
|
||||
(send editor insert (format "~a of ~a tests failed. See below for details.\n\n"
|
||||
failed-tests total-tests))))
|
||||
(unless (= 0 total-checks)
|
||||
(send editor insert (format "Ran ~a total checks\n" total-checks))
|
||||
(if (= 0 failed-checks)
|
||||
(send editor insert "All checks passed!\n\n")
|
||||
(send editor insert (format "~a of ~a checks failed. See below for details.\n\n"
|
||||
failed-checks total-checks))))
|
||||
(unless (null? covered)
|
||||
(make-covered-button covered editor #f)
|
||||
(send editor insert "\n"))
|
||||
|
||||
(if (testcase-ext?)
|
||||
(send editor insert "Ran the following tests:\n")
|
||||
(send editor insert "Tested the following Example classes:\n"))
|
||||
(for-each
|
||||
(lambda (test-info)
|
||||
(send editor insert "\n")
|
||||
(send editor insert (single-test-name test-info))
|
||||
(unless (null? (single-test-covered-exprs test-info))
|
||||
(make-covered-button (single-test-covered-exprs test-info) editor #t))
|
||||
(unless (null? (single-test-testcases test-info))
|
||||
(let ((num-tests (length (single-test-testcases test-info)))
|
||||
(failed-tests (filter (compose not testcase-passed?)
|
||||
(single-test-testcases test-info))))
|
||||
(next-line)
|
||||
(send editor insert (format "Ran ~a test methods." num-tests))
|
||||
(next-line)
|
||||
(if (null? failed-tests)
|
||||
(send editor insert "All tests passed!")
|
||||
(send editor insert (format "~a of ~a tests failed:"
|
||||
(length failed-tests) num-tests)))
|
||||
(next-line)
|
||||
(for-each (lambda (test)
|
||||
(send editor insert
|
||||
(format "~a ~a" (testcase-name test)
|
||||
(if (testcase-passed? test) "succeeded!" "failed.")))
|
||||
(unless (null? (testcase-covers test))
|
||||
(make-covered-button (testcase-covers test) editor #f))
|
||||
(next-line))
|
||||
(reverse (single-test-testcases test-info)))))
|
||||
(unless (null? (single-test-covered-methods test-info))
|
||||
(next-line)
|
||||
(send editor insert "Tested the following classes:")
|
||||
(next-line)
|
||||
(for-each (lambda (class)
|
||||
(let ((num-methods (length (car (cdr class))))
|
||||
(uncovered-methods (filter (lambda (m) (not (car (cdr m)))) (car (cdr class)))))
|
||||
(send editor insert (format "class ~a with ~a of its methods covered."
|
||||
(car class)
|
||||
(cond
|
||||
((null? uncovered-methods) "all")
|
||||
((= (length uncovered-methods) num-methods) "none")
|
||||
(else
|
||||
(- num-methods (length uncovered-methods))))))
|
||||
(next-line)
|
||||
(let loop ((methods uncovered-methods))
|
||||
(unless (null? methods)
|
||||
(send editor insert (format "Method ~a was not fully covered."
|
||||
(car (car methods))))
|
||||
(next-line)
|
||||
(loop (cdr methods))))))
|
||||
(single-test-covered-methods test-info)))
|
||||
|
||||
(when (> (single-test-num-checks test-info) 0)
|
||||
(next-line)
|
||||
(send editor insert (format "Ran ~a checks." (single-test-num-checks test-info)))
|
||||
(next-line)
|
||||
(if (null? (single-test-failed-checks test-info))
|
||||
(send editor insert "All checks succeeded!\n")
|
||||
(begin
|
||||
(send editor insert (format "~a of ~a checks failed:"
|
||||
(length (single-test-failed-checks test-info))
|
||||
(single-test-num-checks test-info)))
|
||||
(next-line)
|
||||
(for-each (lambda (check)
|
||||
(make-link editor (failed-check-msg check)
|
||||
(failed-check-src check))
|
||||
(next-line))
|
||||
(reverse (single-test-failed-checks test-info)))))
|
||||
))
|
||||
tested-classes)
|
||||
(unless (null? nearly-tested-classes)
|
||||
(send editor insert "\n")
|
||||
(send editor insert "The following classes were not run, but are similar to example classes:\n")
|
||||
(insert-content nearly-tested-classes #f)))))
|
||||
(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)))
|
||||
))
|
||||
|
||||
|
||||
; ##@ $## #
|
||||
; #@ ##
|
||||
; #$&$# :## *###$# $##*#
|
||||
; #*@+# # #$ -# $$ :#
|
||||
; # # # # *###$ #
|
||||
; # # # +# #
|
||||
; # # # # *# $+ :$
|
||||
; ### ### ##### @*###* $##$
|
||||
|
||||
;make-link: text% (listof (U string snip%)) src -> void
|
||||
(define (make-link text msg dest)
|
||||
(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)
|
||||
(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)
|
||||
(let* ([position (src-pos srcloc)]
|
||||
[span (src-span srcloc)]
|
||||
[rep/ed (get-editor srcloc #t)])
|
||||
(when rep/ed
|
||||
(cond
|
||||
[(is-a? (cadr rep/ed) text:basic<%>)
|
||||
(let ((highlight
|
||||
(lambda ()
|
||||
(send (car rep/ed) highlight-error (cadr rep/ed) position (+ position span)))))
|
||||
(queue-callback highlight))]))))
|
||||
|
||||
(define (make-covered-button covered dest partial?)
|
||||
(send dest insert " ")
|
||||
(let* ((editor (new (editor:standard-style-list-mixin text%)
|
||||
[auto-wrap #t]))
|
||||
(snip (new editor-snip% (editor 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 editor insert "Show covered expressions")
|
||||
(send editor insert "Show all covered expressions"))
|
||||
(send dest insert snip)
|
||||
(send dest insert " ")
|
||||
(send editor set-clickback
|
||||
0 (send editor get-end-position)
|
||||
(lambda (t s e)
|
||||
(color-covered covered))
|
||||
#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 (color-covered covered)
|
||||
(unless (null? covered)
|
||||
(let* ([editor (get-editor (car covered) #f)]
|
||||
[style-list (editor:get-standard-style-list)]
|
||||
[uncover-color (send style-list find-named-style "profj:syntax-colors:scheme:uncovered")]
|
||||
[cover-color (send style-list find-named-style "profj:syntax-colors:scheme:covered")])
|
||||
(when editor
|
||||
;(send cover-color set-delta-foreground "darkmagenta")
|
||||
;(send uncover-color set-delta-foreground "black")
|
||||
(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 uncover-color 0 (send editor last-position) #f)
|
||||
(let loop ((srcs covered))
|
||||
(unless (null? srcs)
|
||||
(send editor change-style cover-color (sub1 (src-pos (car srcs)))
|
||||
(sub1 (+ (src-pos (car srcs))
|
||||
(src-span (car srcs)))) #f)
|
||||
(loop (cdr srcs))))
|
||||
(send editor end-test-color))))))
|
||||
(queue-callback color-buff))))))
|
||||
|
||||
(define (get-editor src rep?)
|
||||
(let* ([source (src-file src)]
|
||||
[frame (cond
|
||||
[(path? source) (handler:edit-file source)]
|
||||
[(is-a? source editor<%>)
|
||||
(let ([canvas (send source get-canvas)])
|
||||
(and canvas
|
||||
(send canvas get-top-level-window)))])]
|
||||
[editor (cond
|
||||
[(path? source)
|
||||
(cond
|
||||
[(and frame (is-a? frame #;drscheme:unit:frame<%>))
|
||||
(send frame get-definitions-text)]
|
||||
[(and frame (is-a? frame frame:editor<%>))
|
||||
(send frame get-editor)]
|
||||
[else #f])]
|
||||
[(is-a? source editor<%>) source])]
|
||||
[rep (and frame
|
||||
#;(is-a? frame drscheme:unit:frame%)
|
||||
(send frame get-interactions-text))])
|
||||
(when frame
|
||||
(unless (send frame is-shown?) (send frame show #t)))
|
||||
(if (and rep? rep editor)
|
||||
(list rep editor)
|
||||
(and rep editor))))
|
||||
|
||||
(define (format-src src)
|
||||
(string-append (cond
|
||||
((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-local-member-name toggle-test-status test-froze-colorer? begin-test-color end-test-color)
|
||||
|
||||
(define test-tool@
|
||||
(u:unit
|
||||
(u:import drscheme:tool^)
|
||||
(u:export drscheme:tool-exports^)
|
||||
(define (phase1) (void))
|
||||
(define (phase2) (void))
|
||||
|
||||
(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-unit-frame test-frame-mixin)
|
||||
(drscheme:get/extend:extend-tab test-tab%-mixin)
|
||||
|
||||
))
|
||||
|
||||
)
|
||||
|
|
@ -288,8 +288,10 @@ A program in the teaching languages should be tested using the check forms --
|
|||
@scheme{(check-error value string)}. Tests are evaluated when running the program:
|
||||
when there are no tests, a warning appears in the interactions window;
|
||||
when all tests succeed, an acknowledgement appears in the interactions window;
|
||||
otherwise, a testing window appears to report the results. See @secref["menu:testing"]
|
||||
for details on configuring the report behavior.
|
||||
otherwise, a testing window appears to report the results. See @secref["menu:view"]
|
||||
for details on configuring the report behavior.
|
||||
|
||||
Tests can be disabled if necessary, see @secref["menu:scheme"] for details.
|
||||
|
||||
@; ----------------------------------------
|
||||
|
||||
|
|
@ -346,8 +348,9 @@ Programs in the teaching languages must be tested, using a class containing the
|
|||
all Example classes are instanstiated and all methods prefixed with the word 'test'
|
||||
are run. When there are no tests, a warning appears in the interactions window;
|
||||
when all tests succeed, an acknowledgement appears in the interactions window;
|
||||
otherwise, a testing window appears to report the results. See @secref["menu:testing"]
|
||||
for details on configuring the report behavior.
|
||||
otherwise, a testing window appears to report the results. See @secref["menu:view"]
|
||||
for details on configuring the report behavior. Tests can be disabled if necessary,
|
||||
see @secref["menu:scheme"] for details.
|
||||
|
||||
Unless disabled in the language configuration window, expression-level coverage
|
||||
information is collected during testing. Selecting the buttons within the report
|
||||
|
|
|
|||
|
|
@ -152,7 +152,7 @@ blinking caret. Each window maintains its own Undo and Redo history.
|
|||
|
||||
@; ----------------------------------------
|
||||
|
||||
@section{@onscreen{View}}
|
||||
@section[#:tag "menu:view"]{@onscreen{View}}
|
||||
|
||||
One each of the following show/hide pairs of menu items
|
||||
appears at any time.
|
||||
|
|
@ -193,6 +193,13 @@ appears at any time.
|
|||
@item{@defmenuitem{Hide Profile} Hides any profiling
|
||||
information currently displayed in the DrScheme window.}
|
||||
|
||||
@item{@defmenuitem{Dock Test Report} Like the dock button on the test report
|
||||
window, this causes all test report windows to merge with the appropriate
|
||||
DrScheme window at the bottom of the frame.}
|
||||
@item{@defmenuitem{Undock Test Report} Like the undock button on the test report
|
||||
window, this causes the test reports attached to appropriate DrScheme tabs
|
||||
to become separate windows.}
|
||||
|
||||
@item{@defmenuitem{Show Tracing} Shows a trace of functions called since
|
||||
the last time @onscreen{Run} was clicked. This menu is useful only if
|
||||
you have enabled tracing in the @onscreen{Choose Language...} dialog's
|
||||
|
|
@ -243,7 +250,7 @@ clears only the corresponding teachpack.
|
|||
|
||||
@; ----------------------------------------
|
||||
|
||||
@section{@onscreen{Scheme}}
|
||||
@section[#:tag "menu:scheme"]{@onscreen{Scheme}}
|
||||
|
||||
@itemize{
|
||||
|
||||
|
|
@ -299,6 +306,17 @@ background that signals the source location of an error.}
|
|||
around the text. Uncommenting only removes a @litchar{;} if it
|
||||
appears at the start of a line and it only removes the first
|
||||
@litchar{;} on each line.}
|
||||
|
||||
@item{@defmenuitem{Disable Tests} Stops tests written in the definitions
|
||||
window from evaluating when the program is Run. Tests can be enabled
|
||||
using the @defmenuitem{Enable Tests} menu item. Disabling tests freezes
|
||||
the contents of any existing test report window.
|
||||
}
|
||||
|
||||
@item{@defmenuitem{Enable Tests} Allows tests written in the definitions
|
||||
window to evaluate when the program is Run. Tests can be disabled using
|
||||
the @defmenuitem{Disable Tests} menu item.
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
|
@ -351,28 +369,7 @@ background that signals the source location of an error.}
|
|||
Slideshow picture. Inside the pict box, insert and arrange Scheme
|
||||
boxes that produce picture values.}
|
||||
|
||||
}
|
||||
|
||||
@; ----------------------------------------
|
||||
|
||||
@section[#:tag "menu:testing"]{@onscreen{Testing}}
|
||||
|
||||
This menu is visible when in a language with built-in support for testing;
|
||||
presently this includes the @|HtDP| languages and the ProfessorJ languages.
|
||||
|
||||
@itemize{
|
||||
@item{@defmenuitem{Enable tests} Allows tests written in the definitions
|
||||
window to be evaluated when the program is run.}
|
||||
@item{@defmenuitem{Disable tests} Stops tests written in the definitions
|
||||
window from evaluating when the program is run; disabling tests freezes
|
||||
contents of any existing test report window.}
|
||||
@item{@defmenuitem{Dock report} Like the dock button on the test report
|
||||
window, this causes all test report windows to merge with the appropriate
|
||||
DrScheme window at the bottom of the frame.}
|
||||
@item{@defmenuitem{Undock report} Like the undock button on the test report
|
||||
window, this causes the test reports attached to appropriate DrScheme tabs
|
||||
to become separate windows.}
|
||||
}
|
||||
}
|
||||
|
||||
@; ----------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -1284,7 +1284,7 @@ please adhere to these guidelines:
|
|||
(profj-language-config-class "Class")
|
||||
(profj-language-config-display-array "Print entire contents of arrays?")
|
||||
(profj-language-config-testing-preferences "Testing Preferences") ; Heading for preferences controlling test behavior
|
||||
(profj-language-config-testing-enable "Display testing results on Run?") ; Run should be the word found on the Run button
|
||||
;(profj-language-config-testing-enable "Display testing results on Run?") ; Run should be the word found on the Run button
|
||||
(profj-language-config-testing-coverage "Collect coverage information for tests?")
|
||||
(profj-language-config-support-test-language "Support test Language extension?")
|
||||
(profj-language-config-testing-check "Allow check expression?") ; check should not be translated
|
||||
|
|
@ -1296,10 +1296,11 @@ please adhere to these guidelines:
|
|||
(profj-test-name-example-miscapitalized "Class ~a's name contains a miscapitalized example.")
|
||||
|
||||
;; Close testing window and do not run test cases any more
|
||||
(profj-test-results-close-and-disable "Close and Disable Testing")
|
||||
;(profj-test-results-close-and-disable "Close and Disable Testing")
|
||||
;; Hide docked testing window and do not run test cases any more
|
||||
(profj-test-results-hide-and-disable "Hide and Disable Testing")
|
||||
(profj-test-results-window-title "Test Results")
|
||||
;(profj-test-results-hide-and-disable "Hide and Disable Testing")
|
||||
;Renamed below
|
||||
;(profj-test-results-window-title "Test Results")
|
||||
|
||||
(profj-unsupported "Unsupported")
|
||||
(profj-executables-unsupported "Sorry - executables are not supported for Java at this time")
|
||||
|
|
@ -1312,9 +1313,19 @@ please adhere to these guidelines:
|
|||
(profj-insert-java-comment-box "Insert Java Comment Box")
|
||||
(profj-insert-java-interactions-box "Insert Java Interactions Box")
|
||||
|
||||
;;The Test engine tool
|
||||
;;
|
||||
(test-engine-window-title "Test Results")
|
||||
;;Following two appear in View menu, attach and free test report window from DrScheme frame
|
||||
(test-engine-dock-report "Dock Test Report")
|
||||
(test-engine-undock-report "Undock Test Report")
|
||||
;;Following two appear in Scheme (Java, etc) menu, cause Tests to be Run automatically or not
|
||||
(test-engine-enable-tests "Enable Tests")
|
||||
(test-engine-disable-tests "Disable Tests")
|
||||
|
||||
(profjWizward-insert-java-class "Insert Java Class")
|
||||
(profjWizard-insert-java-union "Insert Java Union")
|
||||
|
||||
|
||||
;; The Test Suite Tool
|
||||
;; Errors
|
||||
(test-case-empty-error "Empty test case")
|
||||
|
|
|
|||
|
|
@ -1266,7 +1266,7 @@
|
|||
(profj-language-config-class "Classe")
|
||||
(profj-language-config-display-array "Montrer le contenu des tableaux ?")
|
||||
(profj-language-config-testing-preferences "Préférences pour les tests") ; Heading for preferences controlling test behavior
|
||||
(profj-language-config-testing-enable "Montrer le résultat des tests lors de l'exécution ?") ; Run should be the word found on the Run button
|
||||
;(profj-language-config-testing-enable "Montrer le résultat des tests lors de l'exécution ?") ; Run should be the word found on the Run button
|
||||
(profj-language-config-testing-coverage "Collecter l'information de couvrage durant les tests ?")
|
||||
(profj-language-config-support-test-language "Supporter l'extension de langage \"test\" ?")
|
||||
(profj-language-config-testing-check "Permettre les expressions de type \"check\" ?") ; check should not be translated
|
||||
|
|
@ -1278,10 +1278,11 @@
|
|||
(profj-test-name-example-miscapitalized "Le mot \"example\" dans le nom de classe ~a doit être écrit \"Example\".")
|
||||
|
||||
;; Close testing window and do not run test cases any more
|
||||
(profj-test-results-close-and-disable "Fermer la fenêtre et arrêter l'exécution des tests")
|
||||
;(profj-test-results-close-and-disable "Fermer la fenêtre et arrêter l'exécution des tests")
|
||||
;; Hide docked testing window and do not run test cases any more
|
||||
(profj-test-results-hide-and-disable "Cacher la fenêtre et arrêter l'exécution des tests")
|
||||
(profj-test-results-window-title "Résultats des tests")
|
||||
;(profj-test-results-hide-and-disable "Cacher la fenêtre et arrêter l'exécution des tests")
|
||||
;Renamed below
|
||||
;(profj-test-results-window-title "Résultats des tests")
|
||||
|
||||
(profj-unsupported "Non-supporté")
|
||||
(profj-executables-unsupported "Désolé - la création d'exécutables n'est pour l'instant pas supportée pour Java")
|
||||
|
|
@ -1294,6 +1295,10 @@
|
|||
(profj-insert-java-comment-box "Insérer une boite à commentaires Java")
|
||||
(profj-insert-java-interactions-box "Insérer une boite à interactions Java")
|
||||
|
||||
;The Test engine tool
|
||||
;;
|
||||
(test-engine-window-title "Résultats des tests")
|
||||
|
||||
(profjWizward-insert-java-class "Insérer une classe Java")
|
||||
(profjWizard-insert-java-union "Insérer un union Java")
|
||||
|
||||
|
|
|
|||
|
|
@ -1181,7 +1181,7 @@
|
|||
(profj-language-config-class "Klasse")
|
||||
(profj-language-config-display-array "Gesamten Inhalt von Arrays ausdrucken?")
|
||||
(profj-language-config-testing-preferences "Einstellungen Testen") ; Heading for preferences controlling test behavior
|
||||
(profj-language-config-testing-enable "Testresultate bei Start anzeigen?") ; Run should be the word found on the Run button
|
||||
;(profj-language-config-testing-enable "Testresultate bei Start anzeigen?") ; Run should be the word found on the Run button
|
||||
(profj-language-config-testing-coverage "Abdeckungsinformationen für Tests sammeln?")
|
||||
(profj-language-config-support-test-language "Spracherweiterung \"test\" unterstützen?")
|
||||
(profj-language-config-testing-check "Check-Ausdruck zulassen?") ; check should not be translated
|
||||
|
|
@ -1193,10 +1193,11 @@
|
|||
(profj-test-name-example-miscapitalized "Das \"example\" im Namen der Klasse ~a sollte \"Example\" geschrieben werden.")
|
||||
|
||||
;; Close testing window and do not run test cases any more
|
||||
(profj-test-results-close-and-disable "Schließen und Testen deaktivieren")
|
||||
;(profj-test-results-close-and-disable "Schließen und Testen deaktivieren")
|
||||
;; Hide docked testing window and do not run test cases any more
|
||||
(profj-test-results-hide-and-disable "Ausblenden und Testen deaktivieren")
|
||||
(profj-test-results-window-title "Testresultate")
|
||||
;(profj-test-results-hide-and-disable "Ausblenden und Testen deaktivieren")
|
||||
;Renamed below
|
||||
;(profj-test-results-window-title "Testresultate")
|
||||
|
||||
(profj-unsupported "Nicht unterstützt")
|
||||
(profj-executables-unsupported "Programmdateien sind für Java bisher noch nicht unterstützt")
|
||||
|
|
@ -1208,6 +1209,10 @@
|
|||
|
||||
(profj-insert-java-comment-box "Java-Kommentarkasten einfügen")
|
||||
(profj-insert-java-interactions-box "Java-Interaktions-Kasten einfügen")
|
||||
|
||||
;;The test engine tool
|
||||
;;
|
||||
(test-engine-window-title "Testresultate")
|
||||
|
||||
(profjWizward-insert-java-class "Java-Klasse einfügen")
|
||||
(profjWizard-insert-java-union "Java-Vereinigung einfügen")
|
||||
|
|
|
|||
|
|
@ -1236,7 +1236,7 @@ please adhere to these guidelines:
|
|||
(profj-language-config-class "クラス")
|
||||
(profj-language-config-display-array "配列の要素をすべて表示しますか？")
|
||||
(profj-language-config-testing-preferences "テストの環境設定") ; Heading for preferences controlling test behavior
|
||||
(profj-language-config-testing-enable "実行時にテスト結果を表示しますか？") ; Run should be the word found on the Run button
|
||||
;(profj-language-config-testing-enable "実行時にテスト結果を表示しますか？") ; Run should be the word found on the Run button
|
||||
(profj-language-config-testing-coverage "テストのためのカバレージ情報を収集しますか？")
|
||||
(profj-language-config-support-test-language "Support test Language extension?")
|
||||
(profj-language-config-testing-check "check 式を使用しますか？") ; check should not be translated
|
||||
|
|
@ -1248,10 +1248,11 @@ please adhere to these guidelines:
|
|||
(profj-test-name-example-miscapitalized "クラス ~a の名前の大小文字が誤っています。")
|
||||
|
||||
;; Close testing window and do not run test cases any more
|
||||
(profj-test-results-close-and-disable "テストを閉じて無効にする")
|
||||
;(profj-test-results-close-and-disable "テストを閉じて無効にする")
|
||||
;; Hide docked testing window and do not run test cases any more
|
||||
(profj-test-results-hide-and-disable "テストを非表示にして無効にする")
|
||||
(profj-test-results-window-title "テスト結果")
|
||||
;(profj-test-results-hide-and-disable "テストを非表示にして無効にする")
|
||||
;Renamed below
|
||||
;(profj-test-results-window-title "テスト結果")
|
||||
|
||||
(profj-unsupported "サポートされていません")
|
||||
(profj-executables-unsupported "申し訳ありません。現バージョンでは Java の実行ファイルはサポートされていません")
|
||||
|
|
@ -1264,6 +1265,10 @@ please adhere to these guidelines:
|
|||
(profj-insert-java-comment-box "Java コメント ボックスを挿入")
|
||||
(profj-insert-java-interactions-box "Java 対話ボックスを挿入")
|
||||
|
||||
;;The Test engine tool
|
||||
;;
|
||||
(test-engine-window-title "テスト結果")
|
||||
|
||||
(profjWizward-insert-java-class "Java クラスを挿入")
|
||||
(profjWizard-insert-java-union "Java Union を挿入")
|
||||
|
||||
|
|
|
|||
|
|
@ -182,7 +182,7 @@
|
|||
(class* frame% ()
|
||||
|
||||
(super-instantiate
|
||||
((string-constant profj-test-results-window-title) #f 400 350))
|
||||
((string-constant test-engine-window-title) #f 400 350))
|
||||
|
||||
(define editor #f)
|
||||
(define switch-func void)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/file scheme/class scheme/unit scheme/contract drscheme/tool framework mred)
|
||||
(require scheme/file scheme/class scheme/unit scheme/contract drscheme/tool framework mred
|
||||
string-constants)
|
||||
(require "test-display.scm")
|
||||
(provide tool@)
|
||||
|
||||
|
|
@ -118,10 +119,9 @@
|
|||
|
||||
(inherit get-menu-bar get-menu% register-capability-menu-item get-definitions-text
|
||||
get-insert-menu)
|
||||
(define testing-menu 'not-init)
|
||||
(define dock-menu-item 'not-init)
|
||||
(define dock-label "Dock Report")
|
||||
(define undock-label "Undock Report")
|
||||
(define dock-label (string-constant test-engine-dock-report))
|
||||
(define undock-label (string-constant test-engine-undock-report))
|
||||
|
||||
(define dock-menu-item%
|
||||
(class menu:can-restore-menu-item%
|
||||
|
|
@ -156,12 +156,11 @@
|
|||
(send dock-menu-item set-docked?! dock?)))
|
||||
|
||||
(define/private (test-menu-init)
|
||||
(let ([menu-bar (get-menu-bar)]
|
||||
[test-label "Testing"]
|
||||
[enable-label "Enable Tests"]
|
||||
[disable-label "Disable Tests"])
|
||||
(let ([language-menu (send this get-language-menu)]
|
||||
[enable-label (string-constant test-engine-enable-tests)]
|
||||
[disable-label (string-constant test-engine-disable-tests)])
|
||||
|
||||
(set! testing-menu (make-object (get-menu%) test-label menu-bar))
|
||||
(make-object separator-menu-item% language-menu)
|
||||
(letrec ([enable-menu-item%
|
||||
(class menu:can-restore-menu-item%
|
||||
(define enabled? #t)
|
||||
|
|
@ -181,42 +180,22 @@
|
|||
[enable? (get-preference 'tests:enable? (lambda () #t))]
|
||||
[enable-menu-item (make-object enable-menu-item%
|
||||
(if enable? disable-label enable-label)
|
||||
testing-menu
|
||||
language-menu
|
||||
(lambda (_1 _2)
|
||||
(if (send _1 is-test-enabled?)
|
||||
(send _1 disable-tests)
|
||||
(send _1 enable-tests))) #f)])
|
||||
|
||||
(send enable-menu-item set-test-enabled?! enable?)
|
||||
(register-capability-menu-item 'tests:test-menu testing-menu))))
|
||||
|
||||
(define/override (language-changed)
|
||||
(super language-changed)
|
||||
(let* ([settings (send (get-definitions-text) get-next-settings)]
|
||||
[language (drscheme:language-configuration:language-settings-language settings)]
|
||||
[show-testing (send language capability-value 'tests:test-menu)]
|
||||
[insert-menu (get-insert-menu)])
|
||||
(when (eq? testing-menu 'not-init) (test-menu-init))
|
||||
(cond
|
||||
[show-testing
|
||||
(let ([menus (send (send testing-menu get-parent) get-items)])
|
||||
(let d-loop ([m menus]) (unless (null? m) (send (car m) delete) (d-loop (cdr m))))
|
||||
(let r-loop ([m menus])
|
||||
(unless (null? m)
|
||||
(cond
|
||||
[(eq? (car m) insert-menu)
|
||||
(send (car m) restore)
|
||||
(send testing-menu restore)
|
||||
(r-loop (cdr m))]
|
||||
[else (send (car m) restore) (r-loop (cdr m))]))))]
|
||||
[else (send testing-menu delete)])))
|
||||
|
||||
(register-capability-menu-item 'tests:test-menu language-menu))))
|
||||
|
||||
(unless (drscheme:language:capability-registered? 'tests:dock-menu)
|
||||
(drscheme:language:register-capability 'tests:dock-menu (flat-contract boolean?) #f))
|
||||
|
||||
(unless (drscheme:language:capability-registered? 'tests:test-menu)
|
||||
(drscheme:language:register-capability 'tests:test-menu (flat-contract boolean?) #f))
|
||||
(super-instantiate ())
|
||||
(test-menu-init)
|
||||
))
|
||||
|
||||
(define (test-tab%-mixin %)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user