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

Added a safe car because I've seen an error with it, but now the error

Browse Source 
is not happening.  Better leave it in.
(Also, reformat.)

svn: r9748
This commit is contained in:
Eli Barzilay 2008-05-08 17:40:41 +00:00
parent 9561e94bd6
commit 44e73c735f
1 changed files with 171 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

314
collects/tests/framework/group-test.ss
View File

@ -1,161 +1,173 @@
(module group-test mzscheme #lang mzscheme
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
(define windows-menu-prefix (define windows-menu-prefix
(let ([basics (list "Bring Frame to Front..." "Most Recent Window" (let ([basics (list "Bring Frame to Front..." "Most Recent Window"
#f)]) #f)])
(if (eq? (system-type) 'macosx) (if (eq? (system-type) 'macosx)
(list* "Minimize" "Zoom" #f basics) (list* "Minimize" "Zoom" #f basics)
basics))) basics)))
(send-sexp-to-mred
'(define-syntax car*
(syntax-rules ()
[(car* x) (if (pair? x)
(car x)
(error 'car* "got a non-pair for ~s" 'x))])))
(test (test
'exit-on 'exit-on
(lambda (x) (equal? x '("first"))) (lambda (x) (equal? x '("first")))
(lambda () (lambda ()
(send-sexp-to-mred (send-sexp-to-mred
'(begin (send (make-object frame:basic% "first") show #t) '(begin (send (make-object frame:basic% "first") show #t)
(preferences:set 'framework:verify-exit #t))) (preferences:set 'framework:verify-exit #t)))
(wait-for-frame "first") (wait-for-frame "first")
(send-sexp-to-mred (send-sexp-to-mred
`(queue-callback (lambda () (send (get-top-level-focus-window) close)))) `(queue-callback (lambda () (send (get-top-level-focus-window) close))))
(wait-for-frame "Warning") (wait-for-frame "Warning")
(send-sexp-to-mred (send-sexp-to-mred
`(test:button-push "Cancel")) `(test:button-push "Cancel"))
(wait-for-frame "first") (wait-for-frame "first")
(send-sexp-to-mred (send-sexp-to-mred
`(map (lambda (x) (send x get-label)) (send (group:get-the-frame-group) get-frames))))) `(map (lambda (x) (send x get-label))
(send (group:get-the-frame-group) get-frames)))))
;; after the first test, we should have one frame that will always ;; after the first test, we should have one frame that will always
;; be in the group. ;; be in the group.
(test (test
'one-frame-registered 'one-frame-registered
(lambda (x) (equal? x (list "test" "first"))) (lambda (x) (equal? x (list "test" "first")))
(lambda () (lambda ()
(send-sexp-to-mred (send-sexp-to-mred
`(send (make-object frame:basic% "test") show #t)) `(send (make-object frame:basic% "test") show #t))
(wait-for-frame "test") (wait-for-frame "test")
(send-sexp-to-mred (send-sexp-to-mred
`(begin0 `(begin0 (map (lambda (x) (send x get-label))
(map (lambda (x) (send x get-label)) (send (group:get-the-frame-group) get-frames)) (send (group:get-the-frame-group) get-frames))
(send (get-top-level-focus-window) close))))) (send (get-top-level-focus-window) close)))))
(test (test
'two-frames-registered 'two-frames-registered
(lambda (x) (equal? x (list "test2" "test1" "first"))) (lambda (x) (equal? x (list "test2" "test1" "first")))
(lambda () (lambda ()
(send-sexp-to-mred (send-sexp-to-mred
'(send (make-object frame:basic% "test1") show #t)) '(send (make-object frame:basic% "test1") show #t))
(wait-for-frame "test1") (wait-for-frame "test1")
(send-sexp-to-mred (send-sexp-to-mred
'(send (make-object frame:basic% "test2") show #t)) '(send (make-object frame:basic% "test2") show #t))
(wait-for-frame "test2") (wait-for-frame "test2")
(send-sexp-to-mred (send-sexp-to-mred
`(begin0 `(begin0 (let ([frames (send (group:get-the-frame-group) get-frames)])
(let ([frames (send (group:get-the-frame-group) get-frames)]) (for-each (lambda (x)
(for-each (lambda (x) (unless (equal? (send x get-label) "first")
(unless (equal? (send x get-label) "first") (send x close)))
(send x close))) frames)
frames) (map (lambda (x) (send x get-label)) frames))))))
(map (lambda (x) (send x get-label)) frames))))))
(test (test
'one-frame-unregistered 'one-frame-unregistered
(lambda (x) (equal? x (list "test1" "first"))) (lambda (x) (equal? x (list "test1" "first")))
(lambda () (lambda ()
(send-sexp-to-mred (send-sexp-to-mred
'(send (make-object frame:basic% "test1") show #t)) '(send (make-object frame:basic% "test1") show #t))
(wait-for-frame "test1") (wait-for-frame "test1")
(send-sexp-to-mred (send-sexp-to-mred
'(send (make-object frame:basic% "test2") show #t)) '(send (make-object frame:basic% "test2") show #t))
(wait-for-frame "test2") (wait-for-frame "test2")
(queue-sexp-to-mred (queue-sexp-to-mred
`(send (get-top-level-focus-window) close)) `(send (get-top-level-focus-window) close))
(send-sexp-to-mred (send-sexp-to-mred
`(let ([frames (send (group:get-the-frame-group) get-frames)]) `(let ([frames (send (group:get-the-frame-group) get-frames)])
(for-each (lambda (x)
(unless (equal? (send x get-label) "first")
(send x close)))
frames)
(map (lambda (x) (send x get-label)) frames)))))
(test
'windows-menu
(lambda (x)
(equal? x (append windows-menu-prefix (list "first" "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)
(and (is-a? x labelled-menu-item<%>) (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-unshown
(lambda (x)
(equal? x (append windows-menu-prefix (list "first" "test"))))
(lambda ()
(send-sexp-to-mred
'(let ([frame1 (make-object frame:basic% "test")]
[frame2 (make-object frame:basic% "test-not-shown")])
(send frame1 show #t)))
(wait-for-frame "test")
(send-sexp-to-mred
'(begin0 (map (lambda (x)
(and (is-a? x labelled-menu-item<%>) (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 (append windows-menu-prefix (list "aaa" "bbb" "first"))))
(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)
(and (is-a? x labelled-menu-item<%>) (send x get-label)))
(send (car* (send (send (car* frames) get-menu-bar)
get-items))
get-items))
(for-each (lambda (x) (for-each (lambda (x)
(unless (equal? (send x get-label) "first") (unless (equal? (send x get-label) "first")
(send x close))) (send x close)))
frames) frames))))))
(map (lambda (x) (send x get-label)) frames)))))
(test (test
'windows-menu 'windows-menu-sorted2
(lambda (x) (lambda (x)
(equal? x (append windows-menu-prefix (list "first" "test")))) (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
(lambda () (lambda ()
(send-sexp-to-mred (send-sexp-to-mred
'(let ([frame (make-object frame:basic% "test")]) '(let ([frame (make-object frame:basic% "bbb")])
(send frame show #t))) (send frame show #t)))
(wait-for-frame "test") (wait-for-frame "bbb")
(send-sexp-to-mred (send-sexp-to-mred
'(begin0 '(let ([frame (make-object frame:basic% "aaa")])
(map (send frame show #t)))
(lambda (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) (wait-for-frame "aaa")
(send (car (send (send (get-top-level-focus-window) get-menu-bar) get-items)) get-items)) (send-sexp-to-mred
(send (get-top-level-focus-window) close))))) `(let ([frames (send (group:get-the-frame-group) get-frames)])
(begin0 (map (lambda (x)
(test (and (is-a? x labelled-menu-item<%>) (send x get-label)))
'windows-menu-unshown (send (car* (send (send (car* frames) get-menu-bar)
(lambda (x) get-items))
(equal? x (append windows-menu-prefix (list "first" "test")))) get-items))
(lambda () (for-each (lambda (x)
(send-sexp-to-mred (unless (equal? (send x get-label) "first")
'(let ([frame1 (make-object frame:basic% "test")] (send x close)))
[frame2 (make-object frame:basic% "test-not-shown")]) frames))))))
(send frame1 show #t)))
(wait-for-frame "test")
(send-sexp-to-mred
'(begin0
(map
(lambda (x) (and (is-a? x labelled-menu-item<%>) (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 (append windows-menu-prefix (list "aaa" "bbb" "first"))))
(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) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
(send (car (send (send (car frames) get-menu-bar) get-items)) get-items))
(for-each (lambda (x)
(unless (equal? (send x get-label) "first")
(send x close)))
frames))))))
(test
'windows-menu-sorted2
(lambda (x)
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
(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) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
(send (car (send (send (car frames) get-menu-bar) get-items)) get-items))
(for-each (lambda (x)
(unless (equal? (send x get-label) "first")
(send x close)))
frames)))))))