From 339f30b9cb6619fa5169a312ed5e8d135a546b97 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 6 Jul 2013 10:03:36 -0500 Subject: [PATCH] get framework tests running again original commit: 50fb71247deb6bb905cb3a110754d20a6d983764 --- .../gui-test/framework/tests/frame.rkt | 3 +- .../gui-test/framework/tests/main.rkt | 5 +- .../gui-test/framework/tests/private/gui.rkt | 125 ++++++++++++++++++ .../framework/tests/test-suite-utils.rkt | 2 +- 4 files changed, 129 insertions(+), 6 deletions(-) create mode 100644 pkgs/gui-pkgs/gui-test/framework/tests/private/gui.rkt diff --git a/pkgs/gui-pkgs/gui-test/framework/tests/frame.rkt b/pkgs/gui-pkgs/gui-test/framework/tests/frame.rkt index 80837854..88ecba2d 100644 --- a/pkgs/gui-pkgs/gui-test/framework/tests/frame.rkt +++ b/pkgs/gui-pkgs/gui-test/framework/tests/frame.rkt @@ -99,8 +99,7 @@ (define (test-open name class-expression) (let* ([test-file-contents "test"] [tmp-file-name "framework-tmp"] - [tmp-file (build-path (collection-path "tests" "framework") - tmp-file-name)]) + [tmp-file (collection-file-path tmp-file-name "framework" "tests")]) (test name (lambda (x) diff --git a/pkgs/gui-pkgs/gui-test/framework/tests/main.rkt b/pkgs/gui-pkgs/gui-test/framework/tests/main.rkt index 4cbc1a0a..999e37c1 100644 --- a/pkgs/gui-pkgs/gui-test/framework/tests/main.rkt +++ b/pkgs/gui-pkgs/gui-test/framework/tests/main.rkt @@ -12,8 +12,7 @@ (build-path base (string-append (path-element->string name) ".save")))) (define-values (all-files interactive-files) - (let* ([files (call-with-input-file - (build-path (collection-path "tests" "framework") "README") + (let* ([files (call-with-input-file (collection-file-path "README" "framework" "tests") read)] [files (map (lambda (x) (cond [(symbol? x) (symbol->string x)] @@ -85,7 +84,7 @@ (exn->str exn) exn)))]) (debug-printf schedule "beginning ~a test suite\n" x) - (dynamic-require `(lib ,x "tests" "framework") #f) + (dynamic-require `(lib ,x "framework" "tests") #f) (set! jumped-out-tests (remq x jumped-out-tests)) (debug-printf schedule "PASSED ~a test suite\n" x))) (lambda () diff --git a/pkgs/gui-pkgs/gui-test/framework/tests/private/gui.rkt b/pkgs/gui-pkgs/gui-test/framework/tests/private/gui.rkt new file mode 100644 index 00000000..b4709ac1 --- /dev/null +++ b/pkgs/gui-pkgs/gui-test/framework/tests/private/gui.rkt @@ -0,0 +1,125 @@ +#lang racket/base + + (require racket/gui/base + racket/class) + (provide find-labelled-window + find-labelled-windows + whitespace-string=?) + + ;; whitespace-string=? : string string -> boolean + ;; determines if two strings are equal, up to their whitespace. + ;; each string is required to have whitespace in the same place, + ;; but not necessarily the same kinds or amount. + (define (whitespace-string=? string1 string2) + (let loop ([i 0] + [j 0] + [in-whitespace? #t]) + (cond + [(= i (string-length string1)) (only-whitespace? string2 j)] + [(= j (string-length string2)) (only-whitespace? string1 i)] + [else (let ([c1 (string-ref string1 i)] + [c2 (string-ref string2 j)]) + (cond + [in-whitespace? + (cond + [(whitespace? c1) + (loop (+ i 1) + j + #t)] + [(whitespace? c2) + (loop i + (+ j 1) + #t)] + [else (loop i j #f)])] + [(and (whitespace? c1) + (whitespace? c2)) + (loop (+ i 1) + (+ j 1) + #t)] + [(char=? c1 c2) + (loop (+ i 1) + (+ j 1) + #f)] + [else #f]))]))) + + ;; whitespace? : char -> boolean + ;; deteremines if `c' is whitespace + (define (whitespace? c) + (or (char=? c #\newline) + (char=? c #\space) + (char=? c #\tab) + (char=? c #\return))) + + ;; only-whitespace? : string number -> boolean + ;; returns true if string only contains whitespace, from index `i' onwards + (define (only-whitespace? str i) + (let loop ([n i]) + (cond + [(= n (string-length str)) + #t] + [(whitespace? (string-ref str n)) + (loop (+ n 1))] + [else #f]))) + + ;; whitespace-string=? tests + (module+ test + (require rackunit) + (check-equal? #t (whitespace-string=? "a" "a")) + (check-equal? #f (whitespace-string=? "a" "A")) + (check-equal? #f (whitespace-string=? "a" " ")) + (check-equal? #f (whitespace-string=? " " "A")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? "a a" "a a")) + (check-equal? #t (whitespace-string=? "a a" "a a")) + (check-equal? #t (whitespace-string=? "a a" "a a")) + (check-equal? #t (whitespace-string=? " a" "a")) + (check-equal? #t (whitespace-string=? "a" " a")) + (check-equal? #t (whitespace-string=? "a " "a")) + (check-equal? #t (whitespace-string=? "a" "a "))) + + ;;; find-labelled-window : (union ((union #f string) -> window<%>) + ;;; ((union #f string) (union #f class) -> window<%>) + ;;; ((union #f string) (union class #f) area-container<%> -> window<%>)) + ;;;; may call error, if no control with the label is found + (define (find-labelled-window label + [class #f] + [window (get-top-level-focus-window)] + [failure (λ () + (error 'find-labelled-window "no window labelled ~e in ~e~a" + label + window + (if class + (format " matching class ~e" class) + "")))]) + (define windows (find-labelled-windows label class window)) + (cond + [(null? windows) (failure)] + [else (car windows)])) + + (define (find-labelled-windows label [class #f] [window (get-top-level-focus-window)]) + (unless (or (not label) + (string? label)) + (error 'find-labelled-windows "first argument must be a string or #f, got ~e; other args: ~e ~e" + label class window)) + (unless (or (class? class) + (not class)) + (error 'find-labelled-windows "second argument must be a class or #f, got ~e; other args: ~e ~e" + class label window)) + (unless (is-a? window area-container<%>) + (error 'find-labelled-windows "third argument must be a area-container<%>, got ~e; other args: ~e ~e" + window label class)) + (let loop ([window window]) + (cond + [(and (or (not class) + (is-a? window class)) + (let ([win-label (and (is-a? window window<%>) + (send window get-label))]) + (equal? label win-label))) + (list window)] + [(is-a? window area-container<%>) (apply append (map loop (send window get-children)))] + [else '()]))) + + diff --git a/pkgs/gui-pkgs/gui-test/framework/tests/test-suite-utils.rkt b/pkgs/gui-pkgs/gui-test/framework/tests/test-suite-utils.rkt index 7a4d1d74..06295eeb 100644 --- a/pkgs/gui-pkgs/gui-test/framework/tests/test-suite-utils.rkt +++ b/pkgs/gui-pkgs/gui-test/framework/tests/test-suite-utils.rkt @@ -107,7 +107,7 @@ (when load-framework-automatically? (queue-sexp-to-mred '(begin (eval '(require framework)) - (eval '(require tests/utils/gui)))))) + (eval '(require framework/tests/private/gui)))))) (define load-framework-automatically (case-lambda