729 lines
32 KiB
Scheme
729 lines
32 KiB
Scheme
(module tester mzscheme
|
|
|
|
(require (lib "mred.ss" "mred")
|
|
(lib "tool.ss" "drscheme")
|
|
(prefix u: (lib "unit.ss"))
|
|
(lib "framework.ss" "framework")
|
|
(lib "string-constant.ss" "string-constants")
|
|
(lib "class.ss")
|
|
(lib "list.ss")
|
|
(lib "file.ss")
|
|
(lib "etc.ss"))
|
|
|
|
(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)
|
|
(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)
|
|
|
|
))
|
|
|
|
)
|