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

Adding test menu item

Browse Source 
svn: r9319
This commit is contained in:
Kathy Gray 2008-04-15 15:30:15 +00:00
parent 53c4ee3255
commit 9ad02ea7d9
3 changed files with 58 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/profj/tool.ss
View File

@ -308,7 +308,8 @@
profjWizard:special:java-class
profjWizard:special:java-union
drscheme:special:insert-image
drscheme:special:insert-large-letters)) #t]
drscheme:special:insert-large-letters
tests:test-menu)) #t]
[(memq s '(slideshow:special-menu
drscheme:define-popup
profj:special:java-interactions-box)) #f]

12
collects/test-engine/test-display.scm
View File

@ -48,9 +48,9 @@
(send current-tab current-test-window #f)
(send current-tab current-test-editor #f)))))
(if (and drscheme-frame
(get-preference 'profj:test-window:docked?
(get-preference 'test:test-window:docked?
(lambda ()
(put-preferences '(profj:test-window:docked?)
(put-preferences '(test:test-window:docked?)
'(#f))
#f)))
(send drscheme-frame display-test-panel content)
@ -76,7 +76,7 @@
"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"]))))]
[else (format "~a of the ~a tests failed.\n\n" failed-tests total-tests)]))))]
[check-outcomes
(lambda (zero-message)
(send editor insert
@ -213,7 +213,7 @@
(lambda (b c)
(when (eq? 'button (send c get-event-type))
(send this show #f)
(put-preferences '(profj:test-window:docked?)
(put-preferences '(test:test-window:docked?)
'(#t))
(switch-func))))
(make-object grow-box-spacer-pane% button-panel)))
@ -266,7 +266,7 @@
button-panel
(lambda (b c)
(when (eq? 'button (send c get-event-type))
(put-preferences '(profj:test-window:docked?) '(#f))
(put-preferences '(test:test-window:docked?) '(#f))
(send frame undock-tests))))
(define/public (update-editor e)
@ -278,7 +278,7 @@
(define/public (remove)
(let ([parent (get-parent)])
(put-preferences '(profj:test-dock-size)
(put-preferences '(test:test-dock-size)
(list (send parent get-percentages)))
(send parent delete-child this)))))

58
collects/test-engine/test-tool.scm
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require scheme/file scheme/class scheme/unit drscheme/tool framework mred)
(require scheme/file scheme/class scheme/unit scheme/contract drscheme/tool framework mred)
(require "test-display.scm")
(provide tool@)
@ -71,8 +71,7 @@
(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)))])
(get-preference 'test:test-dock-size (lambda () '(2/3 1/3)))])
(send test-frame set-percentages test-box-size))))
(define test-panel null)
(define test-frame null)
@ -105,8 +104,7 @@
(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))])
[dock? (get-preference 'test:test-window:docked? (lambda () #f))])
(cond [(and test-editor panel-shown? dock?)
(send test-panel update-editor test-editor)]
[(and test-editor dock?)
@ -116,7 +114,52 @@
[panel-shown? (send test-panel remove)])
(inner (void) on-tab-change from-tab to-tab)))
(super-instantiate ())))
(inherit get-menu-bar get-menu% register-capability-menu-item get-definitions-text)
(define testing-menu 'not-init)
(define/private (test-menu-init)
(let ([menu-bar (get-menu-bar)]
[test-label "Testing"]
[enable-label "Enable tests"]
[disable-label "Disable tests"])
(set! testing-menu (make-object (get-menu%) test-label menu-bar))
(make-object (class* menu:can-restore-menu-item% ()
(define enabled? #t)
(define/public (test-enabled?) enabled?)
(define/public (test-enable e) (set! enabled? e))
(super-instantiate ()))
disable-label testing-menu
(lambda (_1 _2)
(cond
[(send _1 test-enabled?)
(send _1 set-label enable-label)
(send _1 test-enable #f)
(put-preferences '(tests:enable?) '(#f))]
[else
(send _1 set-label disable-label)
(send _1 test-enable #t)
(put-preferences '(tests:enable?) '(#t))]))
#f)
(make-object menu:can-restore-menu-item%
"Dock tests"
testing-menu
(lambda (_1 _2)
(if (equal? (send _1 get-label) "Dock tests")
(send _1 set-label "Undock tests")
(send _1 set-label "Dock tests"))) #f)
(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)])
(when (eq? testing-menu 'not-init) (test-menu-init))
(if show-testing
(send testing-menu restore)
(send testing-menu delete))))
(drscheme:language:register-capability 'tests:test-menu (flat-contract boolean?) #f)
(super-instantiate ())
))
(define (test-tab%-mixin %)
(class* % ()
@ -141,8 +184,7 @@
[settings
(drscheme:language-configuration:language-settings-settings
language-settings)])
(when (object-method-arity-includes? language
'update-test-setting 2)
(when (object-method-arity-includes? language 'update-test-setting 2)
(let ([next-setting
(drscheme:language-configuration:make-language-settings
language