diff --git a/gui-test/framework/tests/README b/gui-test/framework/tests/README index a039bfa3..fdc5d11f 100644 --- a/gui-test/framework/tests/README +++ b/gui-test/framework/tests/README @@ -49,7 +49,7 @@ signal failures when there aren't any. | error messages when one fails. - frames: |# frame.rkt #| - - canvases: |# canvas.rkt #| + - canvases: canvas.rkt -- now runs directly via raco test. - texts: |# text.rkt #| - pasteboards: |# pasteboard.rkt #| diff --git a/gui-test/framework/tests/canvas.rkt b/gui-test/framework/tests/canvas.rkt index cebe496e..00ff27e7 100644 --- a/gui-test/framework/tests/canvas.rkt +++ b/gui-test/framework/tests/canvas.rkt @@ -1,29 +1,30 @@ #lang racket/base -(require "test-suite-utils.rkt") +(require "private/here-util.rkt" + framework + racket/class + racket/gui/base + rackunit) -(module test racket/base) +(define (test-creation cls name) + (check-true + (parameterize ([current-eventspace (make-eventspace)]) + (define f #f) + (queue-callback + (λ () + (set! f (make-object frame:basic% "test canvas" #f 300 300)) + (define c (make-object cls (send f get-area-container))) + (send c set-editor (make-object text:wide-snip%)) + (send f show #t))) + (wait-for-frame "test canvas" (current-eventspace)) + (queue-callback (λ () (send f show #f))) + #t))) -(define (test-creation class name) - (test - name - (lambda (x) (eq? 'passed x)) - (lambda () - (queue-sexp-to-mred - `(let* ([f (make-object frame:basic% "test canvas" #f 300 300)] - [c (make-object ,class (send f get-area-container))]) - (send c set-editor (make-object text:wide-snip%)) - (send f show #t))) - (wait-for-frame "test canvas") - (queue-sexp-to-mred - `(send (get-top-level-focus-window) show #f)) - 'passed))) +(test-creation (canvas:basic-mixin editor-canvas%) + 'canvas:basic-mixin-creation) +(test-creation canvas:basic% + 'canvas:basic%-creation) -(test-creation '(canvas:basic-mixin editor-canvas%) - 'canvas:basic-mixin-creation) -(test-creation 'canvas:basic% - 'canvas:basic%-creation) - -(test-creation '(canvas:wide-snip-mixin canvas:basic%) - 'canvas:wide-snip-mixin-creation) -(test-creation 'canvas:wide-snip% - 'canvas:wide-snip%-creation) +(test-creation (canvas:wide-snip-mixin canvas:basic%) + 'canvas:wide-snip-mixin-creation) +(test-creation canvas:wide-snip% + 'canvas:wide-snip%-creation) diff --git a/gui-test/framework/tests/private/here-util.rkt b/gui-test/framework/tests/private/here-util.rkt new file mode 100644 index 00000000..f74636c3 --- /dev/null +++ b/gui-test/framework/tests/private/here-util.rkt @@ -0,0 +1,25 @@ +#lang racket/base +(require framework/private/focus-table + racket/gui/base + racket/class) + +(provide wait-for-frame) + +(define (wait-for/here test) + (define timeout 10) + (define pause-time 1/2) + (let loop ([n (ceiling (/ timeout pause-time))]) + (if (zero? n) + (error 'wait-for "after ~a seconds, ~s didn't come true" timeout test) + (unless (test) + (sleep pause-time) + (loop (- n 1)))))) + +(define (wait-for-frame name [eventspace (current-eventspace)]) + (define (check-for-frame) + (for/or ([frame (in-list (frame:lookup-focus-table eventspace))]) + (and (equal? name (send frame get-label)) + frame))) + (wait-for/here + (procedure-rename check-for-frame + (string->symbol (format "check-for-frame-named-\"~a\"" name)))))