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

get framework tests running again

Browse Source 
original commit: 50fb71247deb6bb905cb3a110754d20a6d983764
This commit is contained in:
Robby Findler 2013-07-06 10:03:36 -05:00
parent 99ed019266
commit 339f30b9cb
4 changed files with 129 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/gui-pkgs/gui-test/framework/tests/frame.rkt
View File

@ -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)

5
pkgs/gui-pkgs/gui-test/framework/tests/main.rkt
View File

@ -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 ()

125
pkgs/gui-pkgs/gui-test/framework/tests/private/gui.rkt Normal file
View File

@ -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 '()])))

2
pkgs/gui-pkgs/gui-test/framework/tests/test-suite-utils.rkt
View File

@ -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