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

fixed up some of the old tests

Browse Source 
svn: r6165
This commit is contained in:
Robby Findler 2007-05-07 01:30:32 +00:00
parent 135f37e418
commit 82ec65680d
3 changed files with 22 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/tests/framework/frame.ss
View File

@ -145,23 +145,4 @@
(test-open "frame:searchable open" 'frame:searchable%)
(test-open "frame:text open" 'frame:text%)
;; test to be sure that shutting down one frame doesn't kill others
(test
"custodian shutdown old frame"
(lambda (x) (eq? 'passed x))
(lambda ()
(send-sexp-to-mred
`(let ([c (make-custodian)])
(parameterize ((current-custodian c))
(parameterize ((current-eventspace (make-eventspace)))
(send (new frame:basic% (label "to be shutdown"))
show #t)))
(custodian-shutdown-all c)
(send (new frame:basic% (label "after shutdown")) show #t)))
(wait-for-frame "after shutdown")
(queue-sexp-to-mred
'(send (get-top-level-focus-window) close))
'passed))
)

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

@ -1,5 +1,12 @@
(module group-test mzscheme
(require "test-suite-utils.ss")
(define windows-menu-prefix
(let ([basics (list "Bring Frame to Front..." "Most Recent Window"
#f)])
(if (eq? (system-type) 'macosx)
(list* "Minimize" "Zoom" #f basics)
basics)))
(test
'exit-on
@ -75,8 +82,7 @@
(test
'windows-menu
(lambda (x)
(equal? x (list "Bring Frame to Front..." "Most Recent Window"
#f "first" "test")))
(equal? x (append windows-menu-prefix (list "first" "test"))))
(lambda ()
(send-sexp-to-mred
'(let ([frame (make-object frame:basic% "test")])
@ -92,8 +98,7 @@
(test
'windows-menu-unshown
(lambda (x)
(equal? x (list "Bring Frame to Front..." "Most Recent Window"
#f "first" "test")))
(equal? x (append windows-menu-prefix (list "first" "test"))))
(lambda ()
(send-sexp-to-mred
'(let ([frame1 (make-object frame:basic% "test")]
@ -110,8 +115,7 @@
(test
'windows-menu-sorted1
(lambda (x)
(equal? x (list "Bring Frame to Front..." "Most Recent Window"
#f "aaa" "bbb" "first")))
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
(lambda ()
(send-sexp-to-mred
'(let ([frame (make-object frame:basic% "aaa")])
@ -135,8 +139,7 @@
(test
'windows-menu-sorted2
(lambda (x)
(equal? x (list "Bring Frame to Front..." "Most Recent Window"
#f "aaa" "bbb" "first")))
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
(lambda ()
(send-sexp-to-mred
'(let ([frame (make-object frame:basic% "bbb")])

36
collects/tests/framework/load.ss
View File

@ -26,8 +26,8 @@
(test/load "gui-utils.ss" 'gui-utils:next-untitled-name)
(test/load "test.ss" 'test:run-interval)
(test/load "splash.ss" 'start-splash)
(test/load "framework-sig.ss" '(begin (eval '(require (lib "unitsig.ss")))
(eval '(define-signature dummy-signature^ framework^))))
(test/load "framework-sig.ss" '(begin (eval '(require (lib "unit.ss")))
(eval '(define-signature dummy-signature^ ((open framework^))))))
(test/load "framework-unit.ss" 'framework@)
(test/load "framework.ss" '(list test:button-push
gui-utils:next-untitled-name
@ -39,27 +39,13 @@
"framework.ss"
;; these extra evals let me submit multiple, independent top-level
;; expressions in the newly created namespace.
'(begin (eval '(require (lib "unitsig.ss")))
'(begin (eval '(require (lib "unit.ss")))
(eval '(require-for-syntax (lib "unit-exptime.ss")))
(eval '(define-syntax (signature->symbols stx)
(syntax-case stx ()
[(_ sig)
(let-values ([(_1 eles _2 _3) (signature-members #'sig #'whatever)])
(with-syntax ([eles eles])
#''eles))])))
(eval '(require (lib "framework-sig.ss" "framework")))
(eval '(letrec ([prepend-symbol
(lambda (s1)
(lambda (s2)
(string->symbol
(string-append
(symbol->string s1)
":"
(symbol->string s2)))))]
;; exp-sig = (union (vectorof exp-sig)
;; (cons sym exp-sig)
;; symbol)
[flatten ;; : exp-sig -> (listof symbol)
(lambda (l)
(cond
[(vector? l)
(apply append (map flatten (vector->list l)))]
[(pair? l)
(map (prepend-symbol (car l)) (flatten (cdr l)))]
[(symbol? l) (list l)]
[else (error 'flatten "unk: ~e" l)]))]
[names (flatten (signature->symbols framework^))])
(for-each eval names))))))
(eval '(for-each eval (signature->symbols framework^))))))