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

what happened here?

Browse Source
This commit is contained in:
Robby Findler 2011-01-07 09:23:51 -06:00
parent a32adbe7db
commit bf031be73e
15 changed files with 255 additions and 277 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/tests/framework/canvas.rkt
View File

@ -1,18 +1,18 @@
(module canvas mzscheme #lang racket/base
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
(define (test-creation class name) (define (test-creation class name)
(test (test
name name
(lambda (x) (eq? 'passed x)) (lambda (x) (eq? 'passed x))
(lambda () (lambda ()
(send-sexp-to-mred (queue-sexp-to-mred
`(let* ([f (make-object frame:basic% "test canvas" #f 300 300)] `(let* ([f (make-object frame:basic% "test canvas" #f 300 300)]
[c (make-object ,class (send f get-area-container))]) [c (make-object ,class (send f get-area-container))])
(send c set-editor (make-object text:wide-snip%)) (send c set-editor (make-object text:wide-snip%))
(send f show #t))) (send f show #t)))
(wait-for-frame "test canvas") (wait-for-frame "test canvas")
(send-sexp-to-mred (queue-sexp-to-mred
`(send (get-top-level-focus-window) show #f)) `(send (get-top-level-focus-window) show #f))
'passed))) 'passed)))
@ -25,4 +25,3 @@
'canvas:wide-snip-mixin-creation) 'canvas:wide-snip-mixin-creation)
(test-creation 'canvas:wide-snip% (test-creation 'canvas:wide-snip%
'canvas:wide-snip%-creation) 'canvas:wide-snip%-creation)
)

3
collects/tests/framework/debug.rkt
View File

@ -1,4 +1,5 @@
#lang mzscheme #lang racket/base
(require (for-syntax racket/base))
(provide debug-printf debug-when) (provide debug-printf debug-when)
;; all of the steps in the tcp connection ;; all of the steps in the tcp connection

5
collects/tests/framework/exit.rkt
View File

@ -1,5 +1,5 @@
(module exit mzscheme #lang racket/base
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
(test 'exit/no-prompt (test 'exit/no-prompt
(lambda (x) (lambda (x)
@ -47,4 +47,3 @@
(with-handlers ([eof-result? (lambda (x) 'passed)]) (with-handlers ([eof-result? (lambda (x) 'passed)])
(send-sexp-to-mred (send-sexp-to-mred
`(exit:exit)))))) `(exit:exit))))))
)

33
collects/tests/framework/frame.rkt
View File

@ -1,4 +1,5 @@
(module frame mzscheme #lang racket/base
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
(send-sexp-to-mred '(send (make-object frame:basic% (send-sexp-to-mred '(send (make-object frame:basic%
@ -11,12 +12,10 @@
(lambda (x) (eq? 'passed x)) (lambda (x) (eq? 'passed x))
(lambda () (lambda ()
(let ([frame-label (let ([frame-label
(send-sexp-to-mred (queue-sexp-to-mred
`(queue-callback/res `(let ([f (instantiate ,class-expression () ,@args)])
(λ () (send f show #t)
(let ([f (instantiate ,class-expression () ,@args)]) (send f get-label)))])
(send f show #t)
(send f get-label)))))])
(wait-for-frame frame-label) (wait-for-frame frame-label)
(queue-sexp-to-mred (queue-sexp-to-mred
'(send (get-top-level-focus-window) close)) '(send (get-top-level-focus-window) close))
@ -110,7 +109,7 @@
(equal? x test-file-contents)) (equal? x test-file-contents))
(lambda () (lambda ()
(let ([frame-name (let ([frame-name
(send-sexp-to-mred (queue-sexp-to-mred
`(let ([frame (new ,class-expression)]) `(let ([frame (new ,class-expression)])
(preferences:set 'framework:file-dialogs 'common) (preferences:set 'framework:file-dialogs 'common)
(send frame show #t) (send frame show #t)
@ -122,10 +121,11 @@
(call-with-output-file tmp-file (call-with-output-file tmp-file
(lambda (port) (lambda (port)
(display test-file-contents port)) (display test-file-contents port))
'truncate) #:exists 'truncate)
(queue-sexp-to-mred
`(send (find-labelled-window "Filename:") focus))
(send-sexp-to-mred (send-sexp-to-mred
`(begin (send (find-labelled-window "Filename:") focus) `(begin ,(case (system-type)
,(case (system-type)
[(macos macosx) `(test:keystroke #\a '(meta))] [(macos macosx) `(test:keystroke #\a '(meta))]
[(unix) `(test:keystroke #\a '(meta))] [(unix) `(test:keystroke #\a '(meta))]
[(windows) `(test:keystroke #\a '(control))] [(windows) `(test:keystroke #\a '(control))]
@ -135,16 +135,15 @@
(test:keystroke #\return))) (test:keystroke #\return)))
(wait-for-frame tmp-file-name) (wait-for-frame tmp-file-name)
(begin0 (begin0
(queue-sexp-to-mred
`(let* ([w (get-top-level-focus-window)])
(send (send w get-editor) get-text)))
(send-sexp-to-mred (send-sexp-to-mred
`(let* ([w (get-top-level-focus-window)] `(test:close-top-level-window (get-top-level-focus-window)))
[t (send (send w get-editor) get-text)])
(test:close-top-level-window w)
t))
(wait-for-frame frame-name) (wait-for-frame frame-name)
(queue-sexp-to-mred (queue-sexp-to-mred
`(send (get-top-level-focus-window) close)))))))) `(send (get-top-level-focus-window) close))))))))
(test-open "frame:searchable open" 'frame:searchable%) (test-open "frame:searchable open" 'frame:searchable%)
(test-open "frame:text open" 'frame:text%) (test-open "frame:text open" 'frame:text%)
)

38
collects/tests/framework/group-test.rkt
View File

@ -1,4 +1,4 @@
#lang mzscheme #lang racket/base
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
(define windows-menu-prefix (define windows-menu-prefix
@ -48,10 +48,10 @@
'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 (queue-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 (queue-sexp-to-mred
`(begin0 (map (lambda (x) (send x get-label)) `(begin0 (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)))))
@ -60,13 +60,13 @@
'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 (queue-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 (queue-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 (queue-sexp-to-mred
`(begin0 (let ([frames (send (group:get-the-frame-group) get-frames)]) `(begin0 (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")
@ -78,15 +78,15 @@
'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 (queue-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 (queue-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 (queue-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) (for-each (lambda (x)
(unless (equal? (send x get-label) "first") (unless (equal? (send x get-label) "first")
@ -101,11 +101,11 @@
(lambda (x) (lambda (x)
(equal? x (append windows-menu-prefix (list "first" "test")))) (equal? x (append windows-menu-prefix (list "first" "test"))))
(lambda () (lambda ()
(send-sexp-to-mred (queue-sexp-to-mred
'(let ([frame (make-object frame:basic% "test")]) '(let ([frame (make-object frame:basic% "test")])
(send frame show #t))) (send frame show #t)))
(wait-for-frame "test") (wait-for-frame "test")
(send-sexp-to-mred (queue-sexp-to-mred
'(begin0 (map (lambda (x) '(begin0 (map (lambda (x)
(and (is-a? x labelled-menu-item<%>) (send x get-label))) (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)
@ -119,12 +119,12 @@
(lambda (x) (lambda (x)
(equal? x (append windows-menu-prefix (list "first" "test")))) (equal? x (append windows-menu-prefix (list "first" "test"))))
(lambda () (lambda ()
(send-sexp-to-mred (queue-sexp-to-mred
'(let ([frame1 (make-object frame:basic% "test")] '(let ([frame1 (make-object frame:basic% "test")]
[frame2 (make-object frame:basic% "test-not-shown")]) [frame2 (make-object frame:basic% "test-not-shown")])
(send frame1 show #t))) (send frame1 show #t)))
(wait-for-frame "test") (wait-for-frame "test")
(send-sexp-to-mred (queue-sexp-to-mred
'(begin0 (map (lambda (x) '(begin0 (map (lambda (x)
(and (is-a? x labelled-menu-item<%>) (send x get-label))) (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)
@ -138,15 +138,15 @@
(lambda (x) (lambda (x)
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first")))) (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
(lambda () (lambda ()
(send-sexp-to-mred (queue-sexp-to-mred
'(let ([frame (make-object frame:basic% "aaa")]) '(let ([frame (make-object frame:basic% "aaa")])
(send frame show #t))) (send frame show #t)))
(wait-for-frame "aaa") (wait-for-frame "aaa")
(send-sexp-to-mred (queue-sexp-to-mred
'(let ([frame (make-object frame:basic% "bbb")]) '(let ([frame (make-object frame:basic% "bbb")])
(send frame show #t))) (send frame show #t)))
(wait-for-frame "bbb") (wait-for-frame "bbb")
(send-sexp-to-mred (queue-sexp-to-mred
`(let ([frames (send (group:get-the-frame-group) get-frames)]) `(let ([frames (send (group:get-the-frame-group) get-frames)])
(begin0 (map (lambda (x) (begin0 (map (lambda (x)
(and (is-a? x labelled-menu-item<%>) (send x get-label))) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
@ -163,15 +163,15 @@
(lambda (x) (lambda (x)
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first")))) (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
(lambda () (lambda ()
(send-sexp-to-mred (queue-sexp-to-mred
'(let ([frame (make-object frame:basic% "bbb")]) '(let ([frame (make-object frame:basic% "bbb")])
(send frame show #t))) (send frame show #t)))
(wait-for-frame "bbb") (wait-for-frame "bbb")
(send-sexp-to-mred (queue-sexp-to-mred
'(let ([frame (make-object frame:basic% "aaa")]) '(let ([frame (make-object frame:basic% "aaa")])
(send frame show #t))) (send frame show #t)))
(wait-for-frame "aaa") (wait-for-frame "aaa")
(send-sexp-to-mred (queue-sexp-to-mred
`(let ([frames (send (group:get-the-frame-group) get-frames)]) `(let ([frames (send (group:get-the-frame-group) get-frames)])
(begin0 (map (lambda (x) (begin0 (map (lambda (x)
(and (is-a? x labelled-menu-item<%>) (send x get-label))) (and (is-a? x labelled-menu-item<%>) (send x get-label)))

35
collects/tests/framework/keys.rkt
View File

@ -1,13 +1,13 @@
(module keys mzscheme #lang racket/base
(require "test-suite-utils.ss")
(require mzlib/include) (require "test-suite-utils.ss")
(test (test
'keymap:aug-keymap%/get-table 'keymap:aug-keymap%/get-table
(lambda (x) (lambda (x)
(equal? '((c:k "abc")) x)) (equal? '((c:k "abc")) x))
(lambda () (lambda ()
(send-sexp-to-mred (queue-sexp-to-mred
'(let ([k (make-object keymap:aug-keymap%)]) '(let ([k (make-object keymap:aug-keymap%)])
(send k add-function "abc" void) (send k add-function "abc" void)
(send k map-function "c:k" "abc") (send k map-function "c:k" "abc")
@ -18,7 +18,7 @@
(lambda (x) (lambda (x)
(equal? x '((c:k "def")))) (equal? x '((c:k "def"))))
(lambda () (lambda ()
(send-sexp-to-mred (queue-sexp-to-mred
'(let ([k (make-object keymap:aug-keymap%)] '(let ([k (make-object keymap:aug-keymap%)]
[ht (make-hasheq)]) [ht (make-hasheq)])
(send k add-function "abc" void) (send k add-function "abc" void)
@ -31,7 +31,7 @@
(lambda (x) (lambda (x)
(equal? x '((c:k "abc-k2")))) (equal? x '((c:k "abc-k2"))))
(lambda () (lambda ()
(send-sexp-to-mred (queue-sexp-to-mred
'(let ([k (make-object keymap:aug-keymap%)] '(let ([k (make-object keymap:aug-keymap%)]
[k1 (make-object keymap:aug-keymap%)] [k1 (make-object keymap:aug-keymap%)]
[k2 (make-object keymap:aug-keymap%)]) [k2 (make-object keymap:aug-keymap%)])
@ -48,7 +48,7 @@
(lambda (x) (lambda (x)
(equal? x '((c:k "abc-k")))) (equal? x '((c:k "abc-k"))))
(lambda () (lambda ()
(send-sexp-to-mred (queue-sexp-to-mred
'(let ([k (make-object keymap:aug-keymap%)] '(let ([k (make-object keymap:aug-keymap%)]
[k1 (make-object keymap:aug-keymap%)]) [k1 (make-object keymap:aug-keymap%)])
(send k1 add-function "abc-k1" void) (send k1 add-function "abc-k1" void)
@ -64,7 +64,7 @@
(lambda (x) (lambda (x)
(string=? x str2)) (string=? x str2))
(lambda () (lambda ()
(send-sexp-to-mred (queue-sexp-to-mred
`(keymap:canonicalize-keybinding-string ,str2))))) `(keymap:canonicalize-keybinding-string ,str2)))))
(test-canonicalize 1 "c:a" "c:a") (test-canonicalize 1 "c:a" "c:a")
@ -260,13 +260,13 @@
(list '((#\c control) (#\[ control)))) (list '((#\c control) (#\[ control))))
)) ))
(send-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #t)) (queue-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #t))
(send-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t)) (queue-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t))
(wait-for-frame "dummy to trick frame group") (wait-for-frame "dummy to trick frame group")
;; test-key : key-spec -> ;; test-key : key-spec ->
;; evaluates a test case represented as a key-spec ;; evaluates a test case represented as a key-spec
(define (test-key key-spec) (define (test-key key-spec i)
(let* ([key-sequences (let* ([key-sequences
((case (system-type) ((case (system-type)
[(macos macosx) key-spec-macos] [(macos macosx) key-spec-macos]
@ -280,7 +280,7 @@
(let ([text-expect (buff-spec-string after)] (let ([text-expect (buff-spec-string after)]
[start-expect (buff-spec-start after)] [start-expect (buff-spec-start after)]
[end-expect (buff-spec-end after)]) [end-expect (buff-spec-end after)])
(test key-sequence (test (list key-sequence i)
(lambda (x) (equal? x (vector text-expect start-expect end-expect))) (lambda (x) (equal? x (vector text-expect start-expect end-expect)))
`(let* ([text (send (get-top-level-focus-window) get-editor)]) `(let* ([text (send (get-top-level-focus-window) get-editor)])
(send text erase) (send text erase)
@ -295,15 +295,16 @@
(define (test-specs frame-name frame-class specs) (define (test-specs frame-name frame-class specs)
(send-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t)) (queue-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t))
(wait-for-frame frame-name) (wait-for-frame frame-name)
(for-each test-key specs) (for ([spec (in-list specs)]
(send-sexp-to-mred `(send (get-top-level-focus-window) close))) [i (in-naturals)])
(test-key spec i))
(queue-sexp-to-mred `(send (get-top-level-focus-window) close)))
(test-specs "global keybindings test" 'frame:text% global-specs) (test-specs "global keybindings test" 'frame:text% global-specs)
(test-specs "scheme mode keybindings test" (test-specs "scheme mode keybindings test"
'(class frame:editor% '(class frame:editor%
(define/override (get-editor%) scheme:text%) (define/override (get-editor%) scheme:text%)
(super-new)) (super-new))
scheme-specs)) scheme-specs)

6
collects/tests/framework/load.rkt
View File

@ -1,5 +1,5 @@
(module load mzscheme #lang racket/base
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
(load-framework-automatically #f) (load-framework-automatically #f)
@ -47,4 +47,4 @@
(with-syntax ([eles eles]) (with-syntax ([eles eles])
#''eles))]))) #''eles))])))
(eval '(require framework/framework-sig)) (eval '(require framework/framework-sig))
(eval '(for-each eval (signature->symbols framework^)))))) (eval '(for-each eval (signature->symbols framework^)))))

10
collects/tests/framework/mem.rkt
View File

@ -1,4 +1,4 @@
#lang mzscheme #lang racket/base
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
; mem-boxes : (list-of (list string (list-of (weak-box TST)))) ; mem-boxes : (list-of (list string (list-of (weak-box TST))))
@ -7,7 +7,7 @@
(define mem-count 10) (define mem-count 10)
(define (test-allocate tag open close) (define (test-allocate tag open close)
(send-sexp-to-mred (queue-sexp-to-mred
`(let ([new-boxes `(let ([new-boxes
(let loop ([n ,mem-count]) (let loop ([n ,mem-count])
(cond (cond
@ -32,7 +32,7 @@
(set! mem-boxes (cons (list ,tag new-boxes) mem-boxes))))) (set! mem-boxes (cons (list ,tag new-boxes) mem-boxes)))))
(define (done) (define (done)
(send-sexp-to-mred (queue-sexp-to-mred
`(begin `(begin
(yield) (collect-garbage) (yield) (collect-garbage)
(yield) (collect-garbage) (yield) (collect-garbage)
@ -110,7 +110,7 @@
(define (test-frame-allocate %) (define (test-frame-allocate %)
(let ([name (format "~s" %)]) (let ([name (format "~s" %)])
(send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f)) (queue-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f))
(test-allocate name (test-allocate name
`(lambda () `(lambda ()
(let ([f (make-object ,% ,name)]) (let ([f (make-object ,% ,name)])
@ -123,7 +123,7 @@
(when (send f is-shown?) (when (send f is-shown?)
(error 'test-frame-allocate "~a instance didn't close" ',%)) (error 'test-frame-allocate "~a instance didn't close" ',%))
(yield) (yield))) (yield) (yield)))
(send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t)))) (queue-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t))))
(test-allocate "frame%" (test-allocate "frame%"
'(lambda () '(lambda ()

259
collects/tests/framework/panel-single.rkt
View File

@ -1,134 +1,135 @@
#lang mzscheme #lang racket/base
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
(test (test
'single-panel 'single-panel
(lambda (x) (eq? x 'passed)) (lambda (x) (eq? x 'passed))
`(let* ([semaphore (make-semaphore 0)] (λ ()
[semaphore-frame% (queue-sexp-to-mred
(class frame% `(let* ([semaphore (make-semaphore 0)]
(define/augment (on-close) (semaphore-post semaphore)) [semaphore-frame%
(super-new))] (class frame%
[f (make-object semaphore-frame% "Single Panel Test")] (define/augment (on-close) (semaphore-post semaphore))
[blue-brush (send the-brush-list find-or-create-brush "BLUE" 'solid)] (super-new))]
[green-brush (send the-brush-list find-or-create-brush "FOREST GREEN" 'solid)] [f (make-object semaphore-frame% "Single Panel Test")]
[black-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid)] [blue-brush (send the-brush-list find-or-create-brush "navy" 'solid)]
[grid-canvas% [green-brush (send the-brush-list find-or-create-brush "lightblue" 'solid)]
(class canvas% [grid-canvas%
(init-field lines) (class canvas%
(init label) (init-field lines)
(inherit get-dc get-client-size) (init label)
(override on-paint) (inherit get-dc get-client-size)
(define (on-paint) (override on-paint)
(let-values ([(width height) (get-client-size)]) (define (on-paint)
(let ([dc (get-dc)] (let-values ([(width height) (get-client-size)])
[single-width (/ width lines)] (let ([dc (get-dc)]
[single-height (/ height lines)]) [single-width (/ width lines)]
(send dc set-pen black-pen) [single-height (/ height lines)])
(let loop ([i lines]) (send dc set-pen "black" 1 'transparent)
(cond (let loop ([i lines])
[(zero? i) (void)] (cond
[else [(zero? i) (void)]
(let loop ([j lines]) [else
(cond (let loop ([j lines])
[(zero? j) (void)] (cond
[else [(zero? j) (void)]
(send dc set-brush [else
(if (= 0 (modulo (+ i j) 2)) (send dc set-brush
blue-brush green-brush)) (if (= 0 (modulo (+ i j) 2))
(send dc draw-rectangle blue-brush green-brush))
(* single-width (- i 1)) (send dc draw-rectangle
(* single-height (- j 1)) (* single-width (- i 1))
single-width (* single-height (- j 1))
single-height) single-width
(loop (- j 1))])) single-height)
(loop (- i 1))]))))) (loop (- j 1))]))
(super-instantiate ()) (loop (- i 1))])))))
(super-instantiate ())
;; soon to be obsolete, hopefully.
(inherit set-label) ;; soon to be obsolete, hopefully.
(set-label label) (inherit set-label)
(set-label label)
(inherit min-width min-height)
(min-width 50) (inherit min-width min-height)
(min-height 50))] (min-width 50)
[border-panel (make-object horizontal-panel% f '(border))] (min-height 50))]
[single-panel (make-object panel:single% border-panel)] [border-panel (make-object horizontal-panel% f '(border))]
[children [single-panel (make-object panel:single% border-panel)]
(list [children
(instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Small") (stretchable-width #f) (stretchable-height #f)) (list
(instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Wide") (stretchable-width #f) (stretchable-height #t)) (new grid-canvas% (lines 3) (parent single-panel) (label "Small") (stretchable-width #f) (stretchable-height #f))
(instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Tall") (stretchable-width #t) (stretchable-height #f)) (new grid-canvas% (lines 3) (parent single-panel) (label "Wide") (stretchable-width #t) (stretchable-height #f))
(instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Wide and Tall") (stretchable-width #t) (stretchable-height #t)))] (new grid-canvas% (lines 3) (parent single-panel) (label "Tall") (stretchable-width #f) (stretchable-height #t))
[active-child (car children)] (new grid-canvas% (lines 3) (parent single-panel) (label "Wide and Tall") (stretchable-width #t) (stretchable-height #t)))]
[radios (make-object horizontal-panel% f)] [active-child (car children)]
[make-radio [radios (make-object horizontal-panel% f)]
(lambda (label choices callback) [make-radio
(let* ([panel (make-object vertical-panel% radios '(border))] (lambda (label choices callback)
[message (make-object message% label panel)] (let* ([panel (make-object vertical-panel% radios '(border))]
[radio (make-object radio-box% #f choices panel (lambda (radio _) (callback radio)))] [message (make-object message% label panel)]
[button (make-object button% [radio (make-object radio-box% #f choices panel (lambda (radio _) (callback radio)))]
"Cycle" panel [button (make-object button%
(lambda (_1 _2) "Cycle" panel
(let ([before (send radio get-selection)] (lambda (_1 _2)
[tot (send radio get-number)]) (let ([before (send radio get-selection)]
(let loop ([n tot]) [tot (send radio get-number)])
(unless (zero? n) (let loop ([n tot])
(send radio set-selection (- tot n)) (unless (zero? n)
(callback radio) (send radio set-selection (- tot n))
(sleep/yield 1) (callback radio)
(loop (- n 1)))) (sleep/yield 1)
(send radio set-selection before) (loop (- n 1))))
(callback radio))))]) (send radio set-selection before)
radio))] (callback radio))))])
[radio radio))]
(make-radio [radio
"Active Child" (make-radio
(map (lambda (x) (send x get-label)) children) "Active Child"
(lambda (radio) (map (lambda (x) (send x get-label)) children)
(let loop ([n (length children)] (lambda (radio)
[cs children]) (let loop ([n (length children)]
(cond [cs children])
[(null? cs) (void)] (cond
[else (let ([c (car cs)]) [(null? cs) (void)]
(if (string=? (send radio get-item-label (send radio get-selection)) [else (let ([c (car cs)])
(send c get-label)) (if (string=? (send radio get-item-label (send radio get-selection))
(begin (set! active-child c) (send c get-label))
(send single-panel active-child active-child)) (begin (set! active-child c)
(loop (- n 1) (send single-panel active-child active-child))
(cdr cs))))]))))] (loop (- n 1)
[vertical-alignment 'center] (cdr cs))))]))))]
[horizontal-alignment 'center] [vertical-alignment 'center]
[update-alignment (lambda () [horizontal-alignment 'center]
(send single-panel set-alignment horizontal-alignment vertical-alignment))] [update-alignment (lambda ()
[horiz (send single-panel set-alignment horizontal-alignment vertical-alignment))]
(make-radio [horiz
"Horizontal Alignment" (make-radio
(list "left" "center" "right") "Horizontal Alignment"
(lambda (radio) (list "left" "center" "right")
(set! horizontal-alignment (string->symbol (send radio get-item-label (send radio get-selection)))) (lambda (radio)
(update-alignment)))] (set! horizontal-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
[vert (update-alignment)))]
(make-radio [vert
"Vertical Alignment" (make-radio
(list "top" "center" "bottom") "Vertical Alignment"
(lambda (radio) (list "top" "center" "bottom")
(set! vertical-alignment (string->symbol (send radio get-item-label (send radio get-selection)))) (lambda (radio)
(update-alignment)))] (set! vertical-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
[buttons (make-object horizontal-panel% f)] (update-alignment)))]
[result 'failed] [buttons (make-object horizontal-panel% f)]
[failed (make-object button% "Failed" buttons (lambda (_1 _2) (semaphore-post semaphore)))] [result 'failed]
[passed (make-object button% "Passed" buttons (lambda (_1 _2) [failed (make-object button% "Failed" buttons (lambda (_1 _2) (semaphore-post semaphore)))]
(set! result 'passed) [passed (make-object button% "Passed" buttons (lambda (_1 _2)
(semaphore-post semaphore)))]) (set! result 'passed)
(send border-panel min-width 100) (semaphore-post semaphore)))])
(send border-panel min-height 100) (send border-panel min-width 100)
(send vert set-selection 1) (send border-panel min-height 100)
(send horiz set-selection 1) (send vert set-selection 1)
(send buttons stretchable-height #f) (send horiz set-selection 1)
(send buttons set-alignment 'right 'center) (send buttons stretchable-height #f)
(send radios stretchable-height #f) (send buttons set-alignment 'right 'center)
(send f show #t) (send radios stretchable-height #f)
(yield semaphore) (send f show #t)
(send f show #f) (yield semaphore)
result)) (send f show #f)
result))))

15
collects/tests/framework/pasteboard.rkt
View File

@ -1,5 +1,5 @@
(module pasteboard mzscheme #lang racket/base
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
(define (test-creation frame class name) (define (test-creation frame class name)
(test (test
@ -7,12 +7,10 @@
(lambda (x) #t) (lambda (x) #t)
(lambda () (lambda ()
(let ([frame-label (let ([frame-label
(send-sexp-to-mred (queue-sexp-to-mred
`(let* ([% (class ,frame `(let* ([f (new (class ,frame
(override get-editor%) (define/override (get-editor%) ,class)
[define (get-editor%) (super-new)))])
,class])]
[f (instantiate % ())])
(preferences:set 'framework:exit-when-no-frames #f) (preferences:set 'framework:exit-when-no-frames #f)
(send f show #t) (send f show #t)
(send f get-label)))]) (send f get-label)))])
@ -47,4 +45,3 @@
(test-creation 'frame:pasteboard% (test-creation 'frame:pasteboard%
'pasteboard:info% 'pasteboard:info%
'pasteboard:info-creation) 'pasteboard:info-creation)
)

32
collects/tests/framework/prefs.rkt
View File

@ -1,29 +1,11 @@
(module prefs mzscheme #lang racket/base
(require "test-suite-utils.ss" (require "test-suite-utils.ss")
mzlib/list)
(define ((check-eq? x) y) (eq? x y)) (define ((check-eq? x) y) (eq? x y))
(define pref-sym 'plt:not-a-real-preference) (define pref-sym 'plt:not-a-real-preference)
(define marshalling-pref-sym 'plt:not-a-real-preference-marshalling) (define marshalling-pref-sym 'plt:not-a-real-preference-marshalling)
(define default-test-sym 'plt:not-a-real-preference-default-test) (define default-test-sym 'plt:not-a-real-preference-default-test)
(define saved-prefs-file
(let loop ([n 0])
(let ([candidate
(build-path (find-system-path 'temp-dir)
(format "saved-prefs.~a" n))])
(if (file-exists? candidate)
(loop (+ n 1))
candidate))))
(define prefs-file (find-system-path 'pref-file))
(when (file-exists? prefs-file)
(copy-file prefs-file saved-prefs-file)
(delete-file prefs-file)
(debug-printf admin "saved preferences file from ~s\n" prefs-file)
(debug-printf admin " to ~s\n" saved-prefs-file))
(shutdown-mred) (shutdown-mred)
(test (test
@ -102,12 +84,4 @@
'failed 'failed
'passed) 'passed)
'passed)))))) 'passed))))))
(when (file-exists? saved-prefs-file)
(debug-printf admin "restoring preferences file from ~s\n" saved-prefs-file)
(debug-printf admin " to ~s\n" prefs-file)
(when (file-exists? prefs-file)
(delete-file prefs-file))
(copy-file saved-prefs-file prefs-file)
(delete-file saved-prefs-file)))

4
collects/tests/framework/scheme.rkt
View File

@ -1,4 +1,4 @@
#lang scheme #lang racket/base
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
@ -14,7 +14,7 @@
(lambda (x) (lambda (x)
(equal? x expected)) (equal? x expected))
(λ () (λ ()
(send-sexp-to-mred (queue-sexp-to-mred
`(let ([t (new scheme:text%)]) `(let ([t (new scheme:text%)])
(send t insert ,str) (send t insert ,str)
(scheme:text-balanced? t ,start ,end)))))) (scheme:text-balanced? t ,start ,end))))))

6
collects/tests/framework/search.rkt
View File

@ -1,5 +1,5 @@
#lang scheme #lang racket/base
(require (for-syntax racket/base))
(require "test-suite-utils.ss") (require "test-suite-utils.ss")
(define-syntax (test-search stx) (define-syntax (test-search stx)
@ -13,7 +13,7 @@
(string->symbol (format "search.ss: line ~a" line)) (string->symbol (format "search.ss: line ~a" line))
(lambda (x) (equal? bubble-table x)) (lambda (x) (equal? bubble-table x))
(lambda () (lambda ()
(send-sexp-to-mred (queue-sexp-to-mred
`(let ([t (new (text:searching-mixin (editor:keymap-mixin text:basic%)))] `(let ([t (new (text:searching-mixin (editor:keymap-mixin text:basic%)))]
[normalize [normalize
(λ (ht) (sort (hash-table-map ht list) (λ (ht) (sort (hash-table-map ht list)

31
collects/tests/framework/test-suite-utils.rkt
View File

@ -1,8 +1,10 @@
#lang scheme #lang racket/base
(require (only-in mzscheme fluid-let) (require (only-in mzscheme fluid-let)
launcher launcher
scheme/system racket/system
racket/tcp
racket/pretty
"debug.ss") "debug.ss")
(provide (provide
@ -140,11 +142,10 @@
(define queue-sexp-to-mred (define queue-sexp-to-mred
(lambda (sexp) (lambda (sexp)
(send-sexp-to-mred (send-sexp-to-mred
`(let ([thunk (lambda () ,sexp)] ;; lotech hygiene `(let ([thunk (lambda () ,sexp)] ;; low tech hygiene
[c (make-channel)]) [c (make-channel)])
(queue-callback (lambda () (channel-put c (thunk)))) (queue-callback (lambda () (channel-put c (thunk))))
(channel-wait c))))) (channel-get c)))))
(define re:tcp-read-error (regexp "tcp-read:")) (define re:tcp-read-error (regexp "tcp-read:"))
(define re:tcp-write-error (regexp "tcp-write:")) (define re:tcp-write-error (regexp "tcp-write:"))
@ -152,7 +153,7 @@
(or (regexp-match re:tcp-read-error (exn-message exn)) (or (regexp-match re:tcp-read-error (exn-message exn))
(regexp-match re:tcp-write-error (exn-message exn)))) (regexp-match re:tcp-write-error (exn-message exn))))
(namespace-require 'scheme) ;; in order to make the eval below work right. (namespace-require 'racket) ;; in order to make the eval below work right.
(define (send-sexp-to-mred sexp) (define (send-sexp-to-mred sexp)
(let/ec k (let/ec k
(let ([show-text (let ([show-text
@ -225,12 +226,12 @@
(raise (make-eof-result)) (raise (make-eof-result))
(case (car answer) (case (car answer)
[(error) [(error)
(error 'send-sexp-to-mred "gracket raised \"~a\"" (second answer))] (error 'send-sexp-to-mred "gracket raised \"~a\"" (list-ref answer 1))]
[(last-error) [(last-error)
(error 'send-sexp-to-mred "gracket (last time) raised \"~a\"" (second answer))] (error 'send-sexp-to-mred "gracket (last time) raised \"~a\"" (list-ref answer 1))]
[(cant-read) (error 'mred/cant-parse (second answer))] [(cant-read) (error 'mred/cant-parse (list-ref answer 1))]
[(normal) [(normal)
(eval (second answer))])))))) (eval (list-ref answer 1))]))))))
(define test (define test
(case-lambda (case-lambda
@ -286,7 +287,15 @@
(sleep ,pause-time) (sleep ,pause-time)
(loop (- n 1)))))))))) (loop (- n 1))))))))))
(define (wait-for sexp) (wait-for/wrapper (lambda (x) x) sexp)) (define (wait-for sexp #:queue? [queue? #f])
(wait-for/wrapper
(lambda (x) x)
(if queue?
`(let ([t (λ () ,sexp)]
[c (make-channel)])
(queue-callback (λ () (channel-put c (t))))
(channel-get c))
sexp)))
(define (wait-for-new-frame sexp) (define (wait-for-new-frame sexp)
(wait-for/wrapper (wait-for/wrapper

46
collects/tests/framework/text.rkt
View File

@ -1,9 +1,10 @@
#lang scheme #lang racket/base
(require "test-suite-utils.ss") (require racket/file
"test-suite-utils.ss")
(define dummy-frame-title "dummy to avoid quitting") (define dummy-frame-title "dummy to avoid quitting")
(send-sexp-to-mred `(send (make-object frame:basic% ,dummy-frame-title) show #t)) (queue-sexp-to-mred `(send (make-object frame:basic% ,dummy-frame-title) show #t))
(define (test-creation frame% class name) (define (test-creation frame% class name)
(test (test
@ -12,29 +13,26 @@
(equal? x (list dummy-frame-title))) ;; ensure no frames left (equal? x (list dummy-frame-title))) ;; ensure no frames left
(lambda () (lambda ()
(let ([label (let ([label
(send-sexp-to-mred (queue-sexp-to-mred
`(let ([f (instantiate (class ,frame% `(let ([f (new (class ,frame%
(override get-editor%) (define/override (get-editor%) ,class)
[define (get-editor%) ,class] (super-new)))])
(super-instantiate ()))
())])
(send (send f get-editor) set-max-undo-history 10) (send (send f get-editor) set-max-undo-history 10)
(send f show #t) (send f show #t)
(send f get-label)))]) (send f get-label)))])
(wait-for-frame label) (wait-for-frame label)
(send-sexp-to-mred `(test:keystroke #\a)) (send-sexp-to-mred `(test:keystroke #\a))
(wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text))) (wait-for #:queue? #t `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text)))
(send-sexp-to-mred (queue-sexp-to-mred
`(begin `(begin
;; remove the `a' to avoid save dialog boxes (and test them, I suppose) ;; remove the `a' to avoid save dialog boxes (and test them, I suppose)
(send (send (get-top-level-focus-window) get-editor) undo) (send (send (get-top-level-focus-window) get-editor) undo)
(send (send (get-top-level-focus-window) get-editor) undo) (send (send (get-top-level-focus-window) get-editor) undo)
(send (send (get-top-level-focus-window) get-editor) lock #t) (send (send (get-top-level-focus-window) get-editor) lock #t)
(send (send (get-top-level-focus-window) get-editor) lock #f))) (send (send (get-top-level-focus-window) get-editor) lock #f)
(queue-sexp-to-mred (send (get-top-level-focus-window) close)))
`(send (get-top-level-focus-window) close)) (queue-sexp-to-mred `(map (lambda (x) (send x get-label)) (get-top-level-windows)))))))
(send-sexp-to-mred `(map (lambda (x) (send x get-label)) (get-top-level-windows)))))))
#| #|
(test-creation 'frame:text% (test-creation 'frame:text%
@ -88,7 +86,7 @@
'highlight-range1 'highlight-range1
(lambda (x) (equal? x 1)) (lambda (x) (equal? x 1))
(λ () (λ ()
(send-sexp-to-mred (queue-sexp-to-mred
`(let ([t (new text:basic%)]) `(let ([t (new text:basic%)])
(send t insert "abc") (send t insert "abc")
(send t highlight-range 1 2 "red") (send t highlight-range 1 2 "red")
@ -98,7 +96,7 @@
'highlight-range2 'highlight-range2
(lambda (x) (equal? x 0)) (lambda (x) (equal? x 0))
(λ () (λ ()
(send-sexp-to-mred (queue-sexp-to-mred
`(let ([t (new text:basic%)]) `(let ([t (new text:basic%)])
(send t insert "abc") (send t insert "abc")
((send t highlight-range 1 2 "red")) ((send t highlight-range 1 2 "red"))
@ -109,7 +107,7 @@
'highlight-range3 'highlight-range3
(lambda (x) (equal? x 0)) (lambda (x) (equal? x 0))
(λ () (λ ()
(send-sexp-to-mred (queue-sexp-to-mred
`(let ([t (new text:basic%)]) `(let ([t (new text:basic%)])
(send t insert "abc") (send t insert "abc")
(send t highlight-range 1 2 "red") (send t highlight-range 1 2 "red")
@ -121,7 +119,7 @@
'highlight-range4 'highlight-range4
(lambda (x) (equal? x 1)) (lambda (x) (equal? x 1))
(λ () (λ ()
(send-sexp-to-mred (queue-sexp-to-mred
`(let ([t (new text:basic%)]) `(let ([t (new text:basic%)])
(send t insert "abc") (send t insert "abc")
(send t highlight-range 1 2 "red") (send t highlight-range 1 2 "red")
@ -135,7 +133,7 @@
'highlight-range5 'highlight-range5
(lambda (x) (equal? x 0)) (lambda (x) (equal? x 0))
(λ () (λ ()
(send-sexp-to-mred (queue-sexp-to-mred
`(let ([t (new text:basic%)]) `(let ([t (new text:basic%)])
(send t insert "abc") (send t insert "abc")
(send t highlight-range 1 2 "red") (send t highlight-range 1 2 "red")
@ -151,7 +149,7 @@
(delete-file tmp-file) (delete-file tmp-file)
(equal? x 0)) (equal? x 0))
(λ () (λ ()
(send-sexp-to-mred (queue-sexp-to-mred
`(let ([t (new text:basic%)]) `(let ([t (new text:basic%)])
(send t insert "abc") (send t insert "abc")
(send t save-file ,tmp-file) (send t save-file ,tmp-file)
@ -172,7 +170,7 @@
'print-to-dc 'print-to-dc
(λ (x) (equal? x 'no-error)) (λ (x) (equal? x 'no-error))
(λ () (λ ()
(send-sexp-to-mred (queue-sexp-to-mred
'(let* ([t (new text:basic%)] '(let* ([t (new text:basic%)]
[bmp (make-object bitmap% 100 40)] [bmp (make-object bitmap% 100 40)]
[dc (new bitmap-dc% (bitmap bmp))]) [dc (new bitmap-dc% (bitmap bmp))])
@ -186,7 +184,7 @@
'print-to-dc2 'print-to-dc2
(λ (x) (equal? x 'no-error)) (λ (x) (equal? x 'no-error))
(λ () (λ ()
(send-sexp-to-mred (queue-sexp-to-mred
`(let* ([f (new frame% [label ""])] `(let* ([f (new frame% [label ""])]
[t (new text:basic%)] [t (new text:basic%)]
[ec (new editor-canvas% [parent f] [editor t])] [ec (new editor-canvas% [parent f] [editor t])]
@ -197,4 +195,4 @@
(send f reflow-container) (send f reflow-container)
(send dc clear) (send dc clear)
(send t print-to-dc dc 1) (send t print-to-dc dc 1)
'no-error)))) 'no-error))))