diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss index f450e0a4..8ee56887 100644 --- a/collects/framework/frame.ss +++ b/collects/framework/frame.ss @@ -73,8 +73,11 @@ (show #f)))]) (sequence (apply super-init args) - (send (group:get-the-frame-group) insert-frame this) - (make-object (get-menu-bar%) this)) + + ;; must make menu before inserting frame into group + ;; or initial windows menu will be wrong + (make-object menu% "Windows" (make-object (get-menu-bar%) this)) + (send (group:get-the-frame-group) insert-frame this)) (private [panel (make-root-area-container (get-area-container%) this)]) (public diff --git a/collects/framework/frameworks.ss b/collects/framework/frameworks.ss index 2d9fdd73..eef3c239 100644 --- a/collects/framework/frameworks.ss +++ b/collects/framework/frameworks.ss @@ -4,6 +4,7 @@ (compile-allow-set!-undefined #t) (require-library "refer.ss") +(require-library "macro.ss") (require-library "cores.ss") (require-library "dates.ss") (require-library "match.ss") diff --git a/collects/framework/group.ss b/collects/framework/group.ss index a8afef30..c4755c7d 100644 --- a/collects/framework/group.ss +++ b/collects/framework/group.ss @@ -21,13 +21,19 @@ (private [get-windows-menu (lambda (frame) - (and (ivar-in-class? 'windows-menu (object-class frame)) - (ivar frame windows-menu)))] + (let ([menu-bar (send frame get-menu-bar)]) + (and menu-bar + (let ([menus (send menu-bar get-items)]) + (ormap (lambda (x) + (if (string=? "Windows" (send x get-label)) + x + #f)) + menus)))))] [insert-windows-menu (lambda (frame) (let ([menu (get-windows-menu frame)]) (when menu - (set! windows-menus (cons (list menu) windows-menus)))))] + (set! windows-menus (cons menu windows-menus)))))] [remove-windows-menu (lambda (frame) (let* ([menu (get-windows-menu frame)]) @@ -35,47 +41,43 @@ (mzlib:function:remove menu windows-menus - (lambda (x y) - (eq? x (car y)))))))] + eq?))))] [update-windows-menus (lambda () (let* ([windows (length windows-menus)] - [get-name (lambda (frame) (send (frame-frame frame) get-label))] + [default-name "Untitled"] + [get-name + (lambda (frame) + (let ([label (send frame get-label)]) + (if (string=? label "") + (if (ivar-in-class? 'get-entire-label (object-class frame)) + (let ([label (send frame get-entire-label)]) + (if (string=? label "") + default-name + label)) + default-name) + label)))] [sorted-frames (mzlib:function:quicksort frames (lambda (f1 f2) - (string-ci<=? (get-name f1) - (get-name f2))))]) - (set! - windows-menus - (map - (lambda (menu-list) - (let ([menu (car menu-list)] - [old-ids (cdr menu-list)]) - (for-each (lambda (id) (send menu delete id)) - old-ids) - (let ([new-ids - (map - (lambda (frame) - (let ([frame (frame-frame frame)] - [default-name "Untitled"]) - (send menu append-item - (let ([label (send frame get-label)]) - (if (string=? label "") - (if (ivar-in-class? 'get-entire-label (object-class frame)) - (let ([label (send frame get-entire-label)]) - (if (string=? label "") - default-name - label)) - default-name) - label)) - (lambda () - (send frame show #t))))) - sorted-frames)]) - (cons menu new-ids)))) - windows-menus))))]) + (string-ci<=? (get-name (frame-frame f1)) + (get-name (frame-frame f2)))))]) + (for-each + (lambda (menu) + (for-each (lambda (item) (send item delete)) + (send menu get-items)) + (for-each + (lambda (frame) + (let ([frame (frame-frame frame)]) + (make-object menu-item% (get-name frame) + menu + (lambda (_1 _2) + (send frame show #t))))) + sorted-frames) + (newline)) + windows-menus)))]) (private [update-close-menu-item-state diff --git a/collects/framework/guiutils.ss b/collects/framework/guiutils.ss index a7029f47..f2863039 100644 --- a/collects/framework/guiutils.ss +++ b/collects/framework/guiutils.ss @@ -107,7 +107,7 @@ (define get-choice (opt-lambda (message true-choice false-choice [title "Warning"]) - (letrec ([result (void)] + (letrec ([result #f] [dialog (make-object dialog% title)] [on-true (lambda args diff --git a/collects/framework/main.ss b/collects/framework/main.ss index e11c2b5e..43d662fa 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -49,7 +49,7 @@ define-some do opt-lambda send* local catch shared unit/sig - with-handlers with-parameterization + with-handlers interface parameterize call-with-input-file with-input-from-file @@ -178,21 +178,21 @@ (set! test #f) (semaphore-post s)))))))) - (preferences:set-default 'framework:just-exit-when-no-frames #t boolean?) + (preferences:set-default 'framework:exit-when-no-frames #f boolean?) (let ([at-most-one (at-most-one-maker)]) (send (group:get-the-frame-group) set-empty-callbacks (lambda () - (if (preferences:get 'framework:just-exit-when-no-frames) - (void) + (if (preferences:get 'framework:exit-when-no-frames) (at-most-one (void) - (lambda () (exit:exit #t))))) + (lambda () (exit:exit #t))) + (void))) (lambda () - (if (preferences:get 'framework:just-exit-when-no-frames) - #t + (if (preferences:get 'framework:exit-when-no-frames) (at-most-one #t (lambda () - (exit:run-callbacks)))))) + (exit:run-callbacks))) + #t))) (exit:insert-callback (lambda () diff --git a/collects/framework/standard-menus-items.ss b/collects/framework/standard-menus-items.ss index 9e2cf3b7..6d97cc00 100644 --- a/collects/framework/standard-menus-items.ss +++ b/collects/framework/standard-menus-items.ss @@ -24,13 +24,13 @@ (define items (list (make-generic 'get-menu% '(lambda () menu%) '("The result of this method is used as the class for creating the result of these methods:" - "@mlink get-file-menu %" + "@ilink frame:standard-menus get-file-menu %" ", " - "@mlink get-edit-menu %" + "@ilink frame:standard-menus get-edit-menu %" ", " - "@mlink get-windows-menu %" + "@ilink frame:standard-menus get-windows-menu %" ", and" - "@mlink get-help-menu %" + "@ilink frame:standard-menus get-help-menu %" ". " "" "@return : (derived-from \\iscmclass{menu})" @@ -56,7 +56,7 @@ (lambda () m)) '("Returns the file menu" "See also" - "@mlink get-menu\\%" + "@ilink frame:standard-menus get-menu\\%" "" "@return : (instance (derived-from \\iscmclass{menu}))")) (make-generic 'get-edit-menu @@ -65,7 +65,7 @@ '("Returns the edit menu" "See also" - "@mlink get-menu\\%" + "@ilink frame:standard-menus get-menu\\%" "" "@return : (instance (derived-from \\iscmclass{menu}))")) (make-generic 'get-windows-menu @@ -74,7 +74,7 @@ '("Returns the windows menu" "See also" - "@mlink get-menu\\%" + "@ilink frame:standard-menus get-menu\\%" "" "@return : (instance (derived-from \\iscmclass{menu}))")) (make-generic 'get-help-menu @@ -83,7 +83,7 @@ '("Returns the help menu" "See also" - "@mlink get-menu\\%" + "@ilink frame:standard-menus get-menu\\%" "" "@return : (instance (derived-from \\iscmclass{menu}))")) diff --git a/collects/tests/framework/README b/collects/tests/framework/README index c0e58c88..fcc4e228 100644 --- a/collects/tests/framework/README +++ b/collects/tests/framework/README @@ -16,8 +16,8 @@ To run a test use: framework-test ... where or is the name of one of the tests -below. Alternatively, pass no command-line arguments to run all of the -tests. +below. Alternatively, pass no command-line arguments to run the same +test as last time. - load: |# load.ss #| @@ -72,12 +72,12 @@ tests. | This tests the info frame. (ie that toolbar on the bottom of the screen) -- group tests: |# group.ss #| +- group tests: |# group-test.ss #| | make sure that mred:the-frame-group records frames correctly. | fake user input expected. -- parenthesis toolkit: |# paren.ss #| +- parenthesis toolkit: |# paren-test.ss #| | Test to be sure that parenthesis matching engine works | No fake user input expected. diff --git a/collects/tests/framework/exit.ss b/collects/tests/framework/exit.ss index c5c49c1f..3cfdb1c5 100644 --- a/collects/tests/framework/exit.ss +++ b/collects/tests/framework/exit.ss @@ -16,7 +16,7 @@ (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #t) (test:run-one (lambda () (exit:exit))))) (wait-for-frame "Warning") - (send-sexp-to-mred '(test:button-push "Quit")) + (wait-for-new-frame '(test:button-push "Quit")) 'failed))) (test 'exit/prompt/no-twice @@ -27,7 +27,7 @@ (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #t) (test:run-one (lambda () (exit:exit))))) (wait-for-frame "Warning") - (send-sexp-to-mred `(test:button-push ,button)))]) + (wait-for-new-frame `(test:button-push ,button)))]) (lambda () (exit/push-button "Cancel") (exit/push-button "Cancel") @@ -35,6 +35,22 @@ (exit/push-button "Quit") 'failed)))) +(test 'exit/esc-cancel + (lambda (x) (and (eq? x 'passed) + (not (mred-running?)))) + (let ([exit/wait-for-warning + (lambda () + (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #t) + (test:run-one (lambda () (exit:exit))))) + (wait-for-frame "Warning"))]) + (lambda () + (exit/wait-for-warning) + (wait-for-new-frame `(test:close-top-level-window (get-top-level-focus-window))) + (exit/wait-for-warning) + (with-handlers ([eof-result? (lambda (x) 'passed)]) + (wait-for-new-frame '(test:button-push "Quit")) + 'failed)))) + (define tmp-file (build-path (find-system-path 'temp-dir) "framework-exit-test-suite")) (test 'exit-callback-called (lambda (x) diff --git a/collects/tests/framework/frame.ss b/collects/tests/framework/frame.ss index 9bb7db25..97f7c47e 100644 --- a/collects/tests/framework/frame.ss +++ b/collects/tests/framework/frame.ss @@ -1,13 +1,14 @@ (define (test-creation name class-expression) - '(test + (test name (lambda (x) x) (lambda () (send-sexp-to-mred - `(send (make-object ,class-expression "test") show #t)) + `(begin (preferences:set 'framework:exit-when-no-frames #f) + (send (make-object ,class-expression "test") show #t))) (wait-for-frame "test") - (send-sexp-to-mred - '(send (get-top-level-focus-window) show #f)) + (queue-sexp-to-mred + '(send (get-top-level-focus-window) close)) #t))) (test-creation @@ -109,9 +110,10 @@ (send-sexp-to-mred `(begin (send (find-labelled-window "Full pathname") focus) ,(case (system-type) - [(macos unix) `(test:keystroke #\a '(meta))] + [(macos) `(test:keystroke #\a '(meta))] + [(unix) `(test:keystroke #\a '(meta))] [(windows) `(test:keystroke #\a '(control))] - [else (error "unknown system type")]) + [else (error "unknown system type: ~a" (system-type))]) (for-each test:keystroke (string->list ,tmp-file)) (test:keystroke #\return))) @@ -123,10 +125,8 @@ (test:close-top-level-window w) t)) (wait-for-frame "test open") - (send-sexp-to-mred - `(begin - (preferences:set 'framework:exit-when-no-frames #t) - (test:close-top-level-window (get-top-level-focus-window))))))))) + (queue-sexp-to-mred + `(send (get-top-level-focus-window) close))))))) (test-open "frame:editor open" 'frame:text%) (test-open "frame:editor open" 'frame:searchable%) diff --git a/collects/tests/framework/group-test.ss b/collects/tests/framework/group-test.ss new file mode 100644 index 00000000..e95ab2e3 --- /dev/null +++ b/collects/tests/framework/group-test.ss @@ -0,0 +1,138 @@ +(test + 'exit-off + (lambda (x) (not (equal? x "test"))) + (lambda () + (send-sexp-to-mred + '(begin (send (make-object frame:basic% "test") show #t) + (preferences:set 'framework:exit-when-no-frames #f))) + (wait-for-frame "test") + (send-sexp-to-mred + `(begin (send (get-top-level-focus-window) close) + (let ([f (get-top-level-focus-window)]) + (if f + (send f get-label) + #f)))))) +(test + 'exit-on + (lambda (x) (not (equal? x "test"))) + (lambda () + (send-sexp-to-mred + '(begin (send (make-object frame:basic% "test") show #t) + (preferences:set 'framework:exit-when-no-frames #t))) + (wait-for-frame "test") + (send-sexp-to-mred + `(queue-callback (lambda () (send (get-top-level-focus-window) close)))) + (wait-for-frame "Warning") + (send-sexp-to-mred + `(test:button-push "Cancel")) + (wait-for-frame "test") + (queue-sexp-to-mred + `(begin (preferences:set 'framework:exit-when-no-frames #f) + (send (get-top-level-focus-window) close) + (let ([f (get-top-level-focus-window)]) + (if f + (send f get-label) + #f)))))) + +(test + 'one-frame-registered + (lambda (x) (equal? x (list "test"))) + (lambda () + (send-sexp-to-mred + `(send (make-object frame:basic% "test") show #t)) + (wait-for-frame "test") + (send-sexp-to-mred + `(begin0 + (map (lambda (x) (send x get-label)) (send (group:get-the-frame-group) get-frames)) + (send (get-top-level-focus-window) close))))) + +(test + 'two-frames-registered + (lambda (x) (equal? x (list "test2" "test1"))) + (lambda () + (send-sexp-to-mred + '(send (make-object frame:basic% "test1") show #t)) + (wait-for-frame "test1") + (send-sexp-to-mred + '(send (make-object frame:basic% "test2") show #t)) + (wait-for-frame "test2") + (send-sexp-to-mred + `(begin0 + (let ([frames (send (group:get-the-frame-group) get-frames)]) + (for-each (lambda (x) (send x close)) frames) + (map (lambda (x) (send x get-label)) frames)))))) + +(test + 'one-frame-unregistered + (lambda (x) (equal? x (list "test1"))) + (lambda () + (send-sexp-to-mred + '(send (make-object frame:basic% "test1") show #t)) + (wait-for-frame "test1") + (send-sexp-to-mred + '(send (make-object frame:basic% "test2") show #t)) + (wait-for-frame "test2") + (queue-sexp-to-mred + `(send (get-top-level-focus-window) close)) + (send-sexp-to-mred + `(let ([frames (send (group:get-the-frame-group) get-frames)]) + (for-each (lambda (x) (send x close)) frames) + (map (lambda (x) (send x get-label)) frames))))) + +(test + 'windows-menu + (lambda (x) + (equal? x (list "test"))) + (lambda () + (send-sexp-to-mred + '(let ([frame (make-object frame:basic% "test")]) + (send frame show #t))) + (wait-for-frame "test") + (send-sexp-to-mred + '(begin0 + (map + (lambda (x) (send x get-label)) + (send (car (send (send (get-top-level-focus-window) get-menu-bar) get-items)) get-items)) + (send (get-top-level-focus-window) close))))) + +(test + 'windows-menu-sorted1 + (lambda (x) + (equal? x (list "aaa" "bbb"))) + (lambda () + (send-sexp-to-mred + '(let ([frame (make-object frame:basic% "aaa")]) + (send frame show #t))) + (wait-for-frame "aaa") + (send-sexp-to-mred + '(let ([frame (make-object frame:basic% "bbb")]) + (send frame show #t))) + (wait-for-frame "bbb") + (send-sexp-to-mred + `(let ([frames (send (group:get-the-frame-group) get-frames)]) + (begin0 + (map + (lambda (x) (send x get-label)) + (send (car (send (send (car frames) get-menu-bar) get-items)) get-items)) + (for-each (lambda (x) (send x close)) frames)))))) + +(test + 'windows-menu-sorted2 + (lambda (x) + (equal? x (list "aaa" "bbb"))) + (lambda () + (send-sexp-to-mred + '(let ([frame (make-object frame:basic% "bbb")]) + (send frame show #t))) + (wait-for-frame "bbb") + (send-sexp-to-mred + '(let ([frame (make-object frame:basic% "aaa")]) + (send frame show #t))) + (wait-for-frame "aaa") + (send-sexp-to-mred + `(let ([frames (send (group:get-the-frame-group) get-frames)]) + (begin0 + (map + (lambda (x) (send x get-label)) + (send (car (send (send (car frames) get-menu-bar) get-items)) get-items)) + (for-each (lambda (x) (send x close)) frames)))))) diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index 36b3f45a..1cbde4c6 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -11,9 +11,15 @@ (define-signature TestSuite^ ((struct eof-result ()) load-framework-automatically - shutdown-listener shutdown-mred mred-running? send-sexp-to-mred + shutdown-listener shutdown-mred mred-running? + send-sexp-to-mred queue-sexp-to-mred test wait-for-frame + + ;; sexp -> void + ;; grabs the frontmost window, executes the sexp and waits for a new frontmost window + wait-for-new-frame + wait-for)) (define-signature internal-TestSuite^ @@ -74,11 +80,11 @@ (set! in-port in) (set! out-port out)) (when load-framework-automatically? - (send-sexp-to-mred + (queue-sexp-to-mred `(begin (require-library "framework.ss" "framework") (require-library "gui.ss" "tests" "utils") - (test:run-interval 11)))))) + (test:run-interval 0)))))) (define load-framework-automatically (case-lambda @@ -109,6 +115,16 @@ (not (eof-object? (peek-char in-port))) #t))) + (define queue-sexp-to-mred + (lambda (sexp) + (send-sexp-to-mred + `(let ([thunk (lambda () ,sexp)] + [sema (make-semaphore 0)]) + (queue-callback (lambda () + (thunk) + (semaphore-post sema))) + (semaphore-wait sema))))) + (define send-sexp-to-mred (lambda (sexp) (let ([show-text @@ -193,17 +209,29 @@ [(continue) (void)] [else (jump)])))))])) - (define (wait-for sexp) + (define (wait-for/wrapper wrapper sexp) (let ([timeout 10] [pause-time 1/2]) (send-sexp-to-mred - `(let loop ([n ,(/ timeout pause-time)]) - (if (zero? n) - (error 'wait-for - ,(format "after ~a seconds, ~s didn't come true" timeout sexp)) - (unless ,sexp - (sleep ,pause-time) - (loop (- n 1)))))))) + (wrapper + `(let ([test (lambda () ,sexp)]) + (let loop ([n ,(/ timeout pause-time)]) + (if (zero? n) + (error 'wait-for + ,(format "after ~a seconds, ~s didn't come true" timeout sexp)) + (unless (test) + (sleep ,pause-time) + (loop (- n 1)))))))))) + + (define (wait-for sexp) (wait-for/wrapper (lambda (x) x) sexp)) + + (define (wait-for-new-frame sexp) + (wait-for/wrapper + (lambda (w) + `(let ([frame (get-top-level-focus-window)]) + ,sexp + ,w)) + `(not (eq? frame (get-top-level-focus-window))))) (define (wait-for-frame name) (wait-for `(let ([win (get-top-level-focus-window)]) @@ -234,15 +262,21 @@ (with-handlers ([(lambda (x) #f) (lambda (x) (display (exn-message x)) (newline))]) - (let ([all-files (map symbol->string (load-relative "README"))] - [files-to-process null] - [command-line-flags - `((multi - [("-o" "--only") - ,(lambda (flag _only-these-tests) - (set! only-these-tests (cons (string->symbol _only-these-tests) - (or only-these-tests null)))) - ("Only run test named " "test-name")]))]) + (let* ([all-files (map symbol->string (load-relative "README"))] + [all? #f] + [files-to-process null] + [command-line-flags + `((once-each + [("-a" "--all") + ,(lambda (flag) + (set! all? #t)) + ("Run all of the tests")]) + (multi + [("-o" "--only") + ,(lambda (flag _only-these-tests) + (set! only-these-tests (cons (string->symbol _only-these-tests) + (or only-these-tests null)))) + ("Only run test named " "test-name")]))]) (let* ([saved-command-line-file (build-path (collection-path "tests" "framework") "saved-command-line.ss")] [parsed-argv (if (equal? argv (vector)) @@ -255,7 +289,7 @@ argv)]) (parse-command-line "framework-test" parsed-argv command-line-flags (lambda (collected . files) - (set! files-to-process (if (null? files) all-files files))) + (set! files-to-process (if (or all? (null? files)) all-files files))) `("Names of the tests; defaults to all tests")) (call-with-output-file saved-command-line-file (lambda (port) diff --git a/collects/tests/framework/pasteboard.ss b/collects/tests/framework/pasteboard.ss index 6ba05f03..2aceee62 100644 --- a/collects/tests/framework/pasteboard.ss +++ b/collects/tests/framework/pasteboard.ss @@ -10,10 +10,11 @@ (lambda () ,class)]))] [f (make-object % "test pasteboard")]) + (preferences:set 'framework:exit-when-no-frames #f) (send f show #t))) (wait-for-frame "test pasteboard") - (send-sexp-to-mred - `(send (get-top-level-focus-window) show #f))))) + (queue-sexp-to-mred + `(send (get-top-level-focus-window) close))))) (test-creation 'frame:editor% '(editor:basic-mixin pasteboard%) @@ -23,7 +24,7 @@ 'pasteboard:basic-creation) (test-creation 'frame:editor% - '(editor:file-mixin pasteboard:basic%) + '(editor:file-mixin pasteboard:keymap%) 'editor:file-mixin-creation) (test-creation 'frame:editor% 'pasteboard:file% diff --git a/collects/tests/framework/text.ss b/collects/tests/framework/text.ss index 292b5811..9835d513 100644 --- a/collects/tests/framework/text.ss +++ b/collects/tests/framework/text.ss @@ -8,6 +8,7 @@ (override [get-editor% (lambda () ,class)]))] [f (make-object % "test text")]) + (preferences:set 'framework:exit-when-no-frames #f) (send f show #t))) (wait-for-frame "test text") (send-sexp-to-mred `(test:keystroke #\a)) @@ -15,8 +16,8 @@ (send-sexp-to-mred `(begin (send (send (get-top-level-focus-window) get-editor) lock #t) (send (send (get-top-level-focus-window) get-editor) lock #f))) - (send-sexp-to-mred - `(send (get-top-level-focus-window) show #f))))) + (queue-sexp-to-mred + `(send (get-top-level-focus-window) close))))) (test-creation 'frame:text% @@ -38,7 +39,7 @@ 'text:return-creation) (test-creation 'frame:text% - '(editor:file-mixin text:basic%) + '(editor:file-mixin text:keymap%) 'editor:file-mixin-creation) (test-creation 'frame:text% 'text:file%