diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index 963cdf7b2f..016cb0dec9 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -533,7 +533,7 @@ keywords] [(drscheme:teachpack-menu-items) htdp-teachpack-callbacks] [(drscheme:special:insert-lambda) #f] - [(tests:test-menu) #t] + [(tests:test-menu tests:dock-menu) #t] [else (inner (drscheme:language:get-capability-default key) capability-value key)])) diff --git a/collects/profj/comb-parsers/parser-units.scm b/collects/profj/comb-parsers/parser-units.scm index b440b3464f..16e0c8aa8e 100644 --- a/collects/profj/comb-parsers/parser-units.scm +++ b/collects/profj/comb-parsers/parser-units.scm @@ -334,7 +334,9 @@ "class instantiation")) (define (new-array type-name) - (sequence (new type-name O_BRACKET (eta expression) C_BRACKET (repeat (sequence (O_BRACKET (eta expression) C_BRACKET) id))) + (sequence (new type-name O_BRACKET (eta expression) C_BRACKET + (repeat (sequence (O_BRACKET (eta expression) C_BRACKET) id)) + (repeat (sequence (O_BRACKET C_BRACKET) id))) id "array instantiation")) (define field-access-end diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 6befd971e3..36435cfe43 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -310,6 +310,7 @@ profjWizard:special:java-union drscheme:special:insert-image drscheme:special:insert-large-letters + tests:dock-menu tests:test-menu)) #t] [(memq s '(slideshow:special-menu drscheme:define-popup diff --git a/collects/test-engine/java-tests.scm b/collects/test-engine/java-tests.scm index 0c945c7e2c..314ba2de65 100644 --- a/collects/test-engine/java-tests.scm +++ b/collects/test-engine/java-tests.scm @@ -72,7 +72,9 @@ [test-class (cadr test)] [test-src (caddr test)]) (send test-info add-test-class test-name test-src) + (send test-info add-testcase 'fields test-src) (let ([test-obj (make-object test-class)]) + (send test-info complete-testcase #t) (set! test-objs (cons test-obj test-objs)) (with-handlers ((exn? (lambda (e) (raise e)))) ((current-eval) @@ -141,14 +143,17 @@ (define/public (get-current-test) current-test) (define/public (get-test-results) test-class-stats) + ;add-testcase: (U string 'fields) (U string src) -> void + ;adds testcase specific information to the info storage (define/pubment (add-testcase name src) (set! current-testcase (make-testcase-stat name src #t null)) - (add-test) + (unless (eq? name 'fields) (add-test)) (inner (void) add-testcase name src)) (define/pubment (complete-testcase pass?) (set-testcase-stat-pass?! current-testcase pass?) - (unless pass? (test-failed (get-current-testcase))) + (unless (eq? (testcase-stat-name current-testcase) 'fields) + (unless pass? (test-failed (get-current-testcase)))) (set-test-stat-cases! current-test (cons current-testcase (test-stat-cases current-test))) (inner (void) complete-testcase pass?)) diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index c851492940..02e8136cf5 100644 --- a/collects/test-engine/test-display.scm +++ b/collects/test-engine/test-display.scm @@ -118,6 +118,8 @@ src-editor) (send editor insert "\n"))) + ;next-line: editor% -> void + ;Inserts a newline and a tab into editor (define/public (next-line editor) (send editor insert "\n\t")) ;; make-link: text% (listof (U string snip%)) src editor -> void diff --git a/collects/test-engine/test-tool.scm b/collects/test-engine/test-tool.scm index 234d719eb2..3d71338b9f 100644 --- a/collects/test-engine/test-tool.scm +++ b/collects/test-engine/test-tool.scm @@ -86,15 +86,11 @@ (for ([t test-windows]) (send t show #f)) (let ([ed (send (get-current-tab) get-test-editor)]) (when ed (display-test-panel ed))) - (unless (send undock-menu-item is-enabled?) (swap-dock-items))) + (send dock-menu-item swap-labels)) (define/public (undock-tests) - (send test-panel remove) + (when (send test-panel is-shown?) (send test-panel remove)) (for ([t test-windows]) (send t show #t)) - (unless (send dock-menu-item is-enabled?) (swap-dock-items))) - - (define/private (swap-dock-items) - (send dock-menu-item enable (not (send dock-menu-item is-enabled?))) - (send undock-menu-item enable (not (send undock-menu-item is-enabled?)))) + (send dock-menu-item swap-labels)) (define/override (make-root-area-container cls parent) (let* ([outer-p (super make-root-area-container @@ -124,52 +120,76 @@ get-insert-menu) (define testing-menu 'not-init) (define dock-menu-item 'not-init) - (define undock-menu-item 'not-init) + (define dock-label "Dock Report") + (define undock-label "Undock Report") + + (define dock-menu-item% + (class menu:can-restore-menu-item% + (inherit set-label) + (define docked? #t) + (define/public (is-report-docked?) docked?) + (define/public (set-docked?! d) (set! docked? d)) + (define/public (swap-labels) + (if docked? + (send this set-label dock-label) + (send this set-label undock-label)) + (set! docked? (not docked?))) + (define/public (dock-report) + (unless docked? (dock-tests) (put-preferences '(test:test-window:docked?) '(#t)))) + (define/public (undock-report) + (when docked? (undock-tests) (put-preferences '(test:test-window:docked?) '(#f)))) + (super-instantiate ()))) + + (define/override (add-show-menu-items show-menu) + (super add-show-menu-items show-menu) + (let ([dock? (get-preference 'test:test-window:docked? (lambda () #t))]) + (when (eq? dock-menu-item 'not-init) + (set! dock-menu-item + (make-object dock-menu-item% + (if dock? undock-label dock-label) + show-menu + (lambda (_1 _2) + (if (send _1 is-report-docked?) + (send _1 undock-report) + (send _1 dock-report))))) + (register-capability-menu-item 'tests:dock-menu show-menu)) + (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"] - [dock-label "Dock report"] - [undock-label "Undock report"]) + [enable-label "Enable Tests"] + [disable-label "Disable Tests"]) (set! testing-menu (make-object (get-menu%) test-label menu-bar)) - (letrec ([enable-opt - (make-object menu:can-restore-menu-item% - enable-label testing-menu - (lambda (_1 _2) - (when (send _1 is-enabled?) - (send _1 enable #f) - (send disable-opt enable #t) - (put-preferences '(tests:enable?) '(#t)))) #f)] - [disable-opt - (make-object menu:can-restore-menu-item% - disable-label testing-menu - (lambda (_1 _2) - (when (send _1 is-enabled?) - (send _1 enable #f) - (send enable-opt enable #t) - (put-preferences '(tests:enable?) '(#f)))) #f)]) - (make-object separator-menu-item% testing-menu) - (set! dock-menu-item (make-object menu:can-restore-menu-item% - dock-label testing-menu - (lambda (_1 _2) - (dock-tests) - (put-preferences '(test:test-window:docked?) '(#t))) #f)) - (set! undock-menu-item (make-object menu:can-restore-menu-item% - undock-label testing-menu - (lambda (_1 _2) - (when (send _1 is-enabled?) - (undock-tests) - (put-preferences '(test:test-window:docked?) '(#f)))) #f)) + (letrec ([enable-menu-item% + (class menu:can-restore-menu-item% + (define enabled? #t) + (define/public (is-test-enabled?) enabled?) + (define/public (set-test-enabled?! e) (set! enabled? e)) + (define/public (enable-tests) + (unless enabled? + (set! enabled? #t) + (send this set-label disable-label) + (put-preferences '(tests:enable?) '(#t)))) + (define/public (disable-tests) + (when enabled? + (set! enabled? #f) + (send this set-label enable-label) + (put-preferences '(tests:enable?) '(#f)))) + (super-instantiate ()))] + [enable? (get-preference 'tests:enable? (lambda () #t))] + [enable-menu-item (make-object enable-menu-item% + (if enable? disable-label enable-label) + testing-menu + (lambda (_1 _2) + (if (send _1 is-test-enabled?) + (send _1 disable-tests) + (send _1 enable-tests))) #f)]) - (if (get-preference 'tests:enable? (lambda () #t)) - (send enable-opt enable #f) - (send disable-opt enable #f)) - (if (get-preference 'test:test-window:docked? (lambda () #t)) - (send dock-menu-item enable #f) - (send undock-menu-item enable #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)] @@ -191,6 +211,9 @@ [else (send (car m) restore) (r-loop (cdr m))]))))] [else (send testing-menu delete)]))) + (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 ())