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

73
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,50 +62,55 @@
[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 (lambda () [failure (λ ()
(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))
(cond
[(null? windows) (failure)]
[else (car windows)]))
(define (find-labelled-windows label [class #f] [window (get-top-level-focus-window)])
(unless (or (not label) (unless (or (not label)
(string? label)) (string? label))
(error 'find-labelled-window "first argument must be a string or #f, got ~e; other args: ~e ~e" (error 'find-labelled-windows "first argument must be a string or #f, got ~e; other args: ~e ~e"
label class window)) label class window))
(unless (or (class? class) (unless (or (class? class)
(not class)) (not class))
(error 'find-labelled-window "second argument must be a class or #f, got ~e; other args: ~e ~e" (error 'find-labelled-windows "second argument must be a class or #f, got ~e; other args: ~e ~e"
class label window)) class label window))
(unless (is-a? window area-container<%>) (unless (is-a? window area-container<%>)
(error 'find-labelled-window "third argument must be a area-container<%>, got ~e; other args: ~e ~e" (error 'find-labelled-windows "third argument must be a area-container<%>, got ~e; other args: ~e ~e"
window label class)) window label class))
(let ([ans
(let loop ([window window]) (let loop ([window window])
(cond (cond
[(and (or (not class) [(and (or (not class)
@ -111,8 +118,8 @@
(let ([win-label (and (is-a? window window<%>) (let ([win-label (and (is-a? window window<%>)
(send window get-label))]) (send window get-label))])
(equal? label win-label))) (equal? label win-label)))
window] (list window)]
[(is-a? window area-container<%>) (ormap loop (send window get-children))] [(is-a? window area-container<%>) (apply append (map loop (send window get-children)))]
[else #f]))]) [else '()])))
(or ans
(failure))))))