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

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

@ -1,4 +1,4 @@
(module group-test mzscheme #lang mzscheme
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
(define windows-menu-prefix (define windows-menu-prefix
@ -7,6 +7,12 @@
(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
@ -23,7 +29,8 @@
`(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.
@ -36,8 +43,8 @@
`(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
@ -51,8 +58,7 @@
'(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)))
@ -89,10 +95,12 @@
(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
@ -106,10 +114,12 @@
(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
@ -127,10 +137,11 @@
(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)))
@ -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))))))