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

add find-labelled-windows

Browse Source 
original commit: e1760fa7c0690697a97343faf3d4991990c19c91
This commit is contained in:
Robby Findler 2012-11-03 10:20:36 -05:00
parent 6706264ae8
commit 49889e566b
1 changed files with 63 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

119
collects/tests/utils/gui.rkt
View File

@ -1,8 +1,10 @@
(module gui mzscheme #lang racket/base
(require mred
mzlib/class (require racket/gui/base
mzlib/etc) racket/class)
(provide find-labelled-window whitespace-string=?) (provide find-labelled-window
find-labelled-windows
whitespace-string=?)
;; whitespace-string=? : string string -> boolean ;; whitespace-string=? : string string -> boolean
;; determines if two strings are equal, up to their whitespace. ;; determines if two strings are equal, up to their whitespace.
@ -60,59 +62,64 @@
[else #f]))) [else #f])))
;; whitespace-string=? tests ;; whitespace-string=? tests
'(map (lambda (x) (apply equal? x)) (module+ test
(list (list #t (whitespace-string=? "a" "a")) (require rackunit)
(list #f (whitespace-string=? "a" "A")) (check-equal? #t (whitespace-string=? "a" "a"))
(list #f (whitespace-string=? "a" " ")) (check-equal? #f (whitespace-string=? "a" "A"))
(list #f (whitespace-string=? " " "A")) (check-equal? #f (whitespace-string=? "a" " "))
(list #t (whitespace-string=? " " " ")) (check-equal? #f (whitespace-string=? " " "A"))
(list #t (whitespace-string=? " " " ")) (check-equal? #t (whitespace-string=? " " " "))
(list #t (whitespace-string=? " " " ")) (check-equal? #t (whitespace-string=? " " " "))
(list #t (whitespace-string=? " " " ")) (check-equal? #t (whitespace-string=? " " " "))
(list #t (whitespace-string=? "a a" "a a")) (check-equal? #t (whitespace-string=? " " " "))
(list #t (whitespace-string=? "a a" "a a")) (check-equal? #t (whitespace-string=? "a a" "a a"))
(list #t (whitespace-string=? "a a" "a a")) (check-equal? #t (whitespace-string=? "a a" "a a"))
(list #t (whitespace-string=? " a" "a")) (check-equal? #t (whitespace-string=? "a a" "a a"))
(list #t (whitespace-string=? "a" " a")) (check-equal? #t (whitespace-string=? " a" "a"))
(list #t (whitespace-string=? "a " "a")) (check-equal? #t (whitespace-string=? "a" " a"))
(list #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<%>) ;;; find-labelled-window : (union ((union #f string) -> window<%>)
;;; ((union #f string) (union #f class) -> window<%>) ;;; ((union #f string) (union #f class) -> window<%>)
;;; ((union #f string) (union class #f) area-container<%> -> window<%>)) ;;; ((union #f string) (union class #f) area-container<%> -> window<%>))
;;;; may call error, if no control with the label is found ;;;; may call error, if no control with the label is found
(define find-labelled-window (define (find-labelled-window label
(opt-lambda (label [class #f]
[class #f] [window (get-top-level-focus-window)]
[window (get-top-level-focus-window)] [failure (λ ()
[failure (lambda () (error 'find-labelled-window "no window labelled ~e in ~e~a"
(error 'find-labelled-window "no window labelled ~e in ~e~a" label
label window
window (if class
(if class (format " matching class ~e" class)
(format " matching class ~e" class) "")))])
"")))]) (define windows (find-labelled-windows label class window))
(unless (or (not label) (cond
(string? label)) [(null? windows) (failure)]
(error 'find-labelled-window "first argument must be a string or #f, got ~e; other args: ~e ~e" [else (car windows)]))
label class window))
(unless (or (class? class) (define (find-labelled-windows label [class #f] [window (get-top-level-focus-window)])
(not class)) (unless (or (not label)
(error 'find-labelled-window "second argument must be a class or #f, got ~e; other args: ~e ~e" (string? label))
class label window)) (error 'find-labelled-windows "first argument must be a string or #f, got ~e; other args: ~e ~e"
(unless (is-a? window area-container<%>) label class window))
(error 'find-labelled-window "third argument must be a area-container<%>, got ~e; other args: ~e ~e" (unless (or (class? class)
window label class)) (not class))
(let ([ans (error 'find-labelled-windows "second argument must be a class or #f, got ~e; other args: ~e ~e"
(let loop ([window window]) class label window))
(cond (unless (is-a? window area-container<%>)
[(and (or (not class) (error 'find-labelled-windows "third argument must be a area-container<%>, got ~e; other args: ~e ~e"
(is-a? window class)) window label class))
(let ([win-label (and (is-a? window window<%>) (let loop ([window window])
(send window get-label))]) (cond
(equal? label win-label))) [(and (or (not class)
window] (is-a? window class))
[(is-a? window area-container<%>) (ormap loop (send window get-children))] (let ([win-label (and (is-a? window window<%>)
[else #f]))]) (send window get-label))])
(or ans (equal? label win-label)))
(failure)))))) (list window)]
[(is-a? window area-container<%>) (apply append (map loop (send window get-children)))]
[else '()])))