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

330
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
(test '(define-syntax car*
'exit-on (syntax-rules ()
(lambda (x) (equal? x '("first"))) [(car* x) (if (pair? x)
(lambda () (car x)
(send-sexp-to-mred (error 'car* "got a non-pair for ~s" 'x))])))
'(begin (send (make-object frame:basic% "first") show #t)
(preferences:set 'framework:verify-exit #t))) (test
(wait-for-frame "first") 'exit-on
(send-sexp-to-mred (lambda (x) (equal? x '("first")))
`(queue-callback (lambda () (send (get-top-level-focus-window) close)))) (lambda ()
(wait-for-frame "Warning") (send-sexp-to-mred
(send-sexp-to-mred '(begin (send (make-object frame:basic% "first") show #t)
`(test:button-push "Cancel")) (preferences:set 'framework:verify-exit #t)))
(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))))) `(queue-callback (lambda () (send (get-top-level-focus-window) close))))
(wait-for-frame "Warning")
;; after the first test, we should have one frame that will always (send-sexp-to-mred
;; be in the group. `(test:button-push "Cancel"))
(wait-for-frame "first")
(test (send-sexp-to-mred
'one-frame-registered `(map (lambda (x) (send x get-label))
(lambda (x) (equal? x (list "test" "first"))) (send (group:get-the-frame-group) get-frames)))))
(lambda ()
(send-sexp-to-mred ;; after the first test, we should have one frame that will always
`(send (make-object frame:basic% "test") show #t)) ;; be in the group.
(wait-for-frame "test")
(send-sexp-to-mred (test
`(begin0 'one-frame-registered
(map (lambda (x) (send x get-label)) (send (group:get-the-frame-group) get-frames)) (lambda (x) (equal? x (list "test" "first")))
(send (get-top-level-focus-window) close))))) (lambda ()
(send-sexp-to-mred
(test `(send (make-object frame:basic% "test") show #t))
'two-frames-registered (wait-for-frame "test")
(lambda (x) (equal? x (list "test2" "test1" "first"))) (send-sexp-to-mred
(lambda () `(begin0 (map (lambda (x) (send x get-label))
(send-sexp-to-mred (send (group:get-the-frame-group) get-frames))
'(send (make-object frame:basic% "test1") show #t)) (send (get-top-level-focus-window) close)))))
(wait-for-frame "test1")
(send-sexp-to-mred (test
'(send (make-object frame:basic% "test2") show #t)) 'two-frames-registered
(wait-for-frame "test2") (lambda (x) (equal? x (list "test2" "test1" "first")))
(send-sexp-to-mred (lambda ()
`(begin0 (send-sexp-to-mred
(let ([frames (send (group:get-the-frame-group) get-frames)]) '(send (make-object frame:basic% "test1") show #t))
(for-each (lambda (x) (wait-for-frame "test1")
(unless (equal? (send x get-label) "first") (send-sexp-to-mred
(send x close))) '(send (make-object frame:basic% "test2") show #t))
frames) (wait-for-frame "test2")
(map (lambda (x) (send x get-label)) frames)))))) (send-sexp-to-mred
`(begin0 (let ([frames (send (group:get-the-frame-group) get-frames)])
(test (for-each (lambda (x)
'one-frame-unregistered (unless (equal? (send x get-label) "first")
(lambda (x) (equal? x (list "test1" "first"))) (send x close)))
(lambda () frames)
(send-sexp-to-mred (map (lambda (x) (send x get-label)) frames))))))
'(send (make-object frame:basic% "test1") show #t))
(wait-for-frame "test1") (test
(send-sexp-to-mred 'one-frame-unregistered
'(send (make-object frame:basic% "test2") show #t)) (lambda (x) (equal? x (list "test1" "first")))
(wait-for-frame "test2") (lambda ()
(queue-sexp-to-mred (send-sexp-to-mred
`(send (get-top-level-focus-window) close)) '(send (make-object frame:basic% "test1") show #t))
(send-sexp-to-mred (wait-for-frame "test1")
`(let ([frames (send (group:get-the-frame-group) get-frames)]) (send-sexp-to-mred
(for-each (lambda (x) '(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)
(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)
(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-sorted2
'windows-menu (lambda (x)
(lambda (x) (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
(equal? x (append windows-menu-prefix (list "first" "test")))) (lambda ()
(lambda () (send-sexp-to-mred
(send-sexp-to-mred '(let ([frame (make-object frame:basic% "bbb")])
'(let ([frame (make-object frame:basic% "test")]) (send frame show #t)))
(send frame show #t))) (wait-for-frame "bbb")
(wait-for-frame "test") (send-sexp-to-mred
(send-sexp-to-mred '(let ([frame (make-object frame:basic% "aaa")])
'(begin0 (send frame show #t)))
(map (wait-for-frame "aaa")
(lambda (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) (send-sexp-to-mred
(send (car (send (send (get-top-level-focus-window) get-menu-bar) get-items)) get-items)) `(let ([frames (send (group:get-the-frame-group) get-frames)])
(send (get-top-level-focus-window) close))))) (begin0 (map (lambda (x)
(and (is-a? x labelled-menu-item<%>) (send x get-label)))
(test (send (car* (send (send (car* frames) get-menu-bar)
'windows-menu-unshown get-items))
(lambda (x) get-items))
(equal? x (append windows-menu-prefix (list "first" "test")))) (for-each (lambda (x)
(lambda () (unless (equal? (send x get-label) "first")
(send-sexp-to-mred (send x close)))
'(let ([frame1 (make-object frame:basic% "test")] frames))))))
[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)
(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)))))))