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

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

@ -1,14 +1,20 @@
(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 ()
@ -23,12 +29,13 @@
`(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 ()
@ -36,11 +43,11 @@
`(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 ()
@ -51,15 +58,14 @@
'(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 ()
@ -79,7 +85,7 @@
frames) frames)
(map (lambda (x) (send x get-label)) frames))))) (map (lambda (x) (send x get-label)) frames)))))
(test (test
'windows-menu 'windows-menu
(lambda (x) (lambda (x)
(equal? x (append windows-menu-prefix (list "first" "test")))) (equal? x (append windows-menu-prefix (list "first" "test"))))
@ -89,13 +95,15 @@
(send frame show #t))) (send frame show #t)))
(wait-for-frame "test") (wait-for-frame "test")
(send-sexp-to-mred (send-sexp-to-mred
'(begin0 '(begin0 (map (lambda (x)
(map (and (is-a? x labelled-menu-item<%>) (send x get-label)))
(lambda (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) (send (car* (send (send (get-top-level-focus-window)
(send (car (send (send (get-top-level-focus-window) get-menu-bar) get-items)) get-items)) get-menu-bar)
get-items))
get-items))
(send (get-top-level-focus-window) close))))) (send (get-top-level-focus-window) close)))))
(test (test
'windows-menu-unshown 'windows-menu-unshown
(lambda (x) (lambda (x)
(equal? x (append windows-menu-prefix (list "first" "test")))) (equal? x (append windows-menu-prefix (list "first" "test"))))
@ -106,13 +114,15 @@
(send frame1 show #t))) (send frame1 show #t)))
(wait-for-frame "test") (wait-for-frame "test")
(send-sexp-to-mred (send-sexp-to-mred
'(begin0 '(begin0 (map (lambda (x)
(map (and (is-a? x labelled-menu-item<%>) (send x get-label)))
(lambda (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) (send (car* (send (send (get-top-level-focus-window)
(send (car (send (send (get-top-level-focus-window) get-menu-bar) get-items)) get-items)) get-menu-bar)
get-items))
get-items))
(send (get-top-level-focus-window) close))))) (send (get-top-level-focus-window) close)))))
(test (test
'windows-menu-sorted1 'windows-menu-sorted1
(lambda (x) (lambda (x)
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first")))) (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
@ -127,16 +137,17 @@
(wait-for-frame "bbb") (wait-for-frame "bbb")
(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)])
(begin0 (begin0 (map (lambda (x)
(map (and (is-a? x labelled-menu-item<%>) (send x get-label)))
(lambda (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) (send (car* (send (send (car* frames) get-menu-bar)
(send (car (send (send (car frames) get-menu-bar) get-items)) get-items)) 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))))))
(test (test
'windows-menu-sorted2 'windows-menu-sorted2
(lambda (x) (lambda (x)
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first")))) (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
@ -151,11 +162,12 @@
(wait-for-frame "aaa") (wait-for-frame "aaa")
(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)])
(begin0 (begin0 (map (lambda (x)
(map (and (is-a? x labelled-menu-item<%>) (send x get-label)))
(lambda (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) (send (car* (send (send (car* frames) get-menu-bar)
(send (car (send (send (car frames) get-menu-bar) get-items)) get-items)) 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))))))