diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index e8cf71af57..7026b25202 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -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] diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index 40e4c81a94..f1cbd29fc3 100644 --- a/collects/test-engine/test-display.scm +++ b/collects/test-engine/test-display.scm @@ -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))))) diff --git a/collects/test-engine/test-tool.scm b/collects/test-engine/test-tool.scm index e21b895461..4c9afb151a 100644 --- a/collects/test-engine/test-tool.scm +++ b/collects/test-engine/test-tool.scm @@ -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