42 lines
1.8 KiB
Scheme
42 lines
1.8 KiB
Scheme
(module gui mzscheme
|
|
(require (lib "mred.ss" "mred"))
|
|
(provide find-labelled-window)
|
|
|
|
;;; find-labelled-window : (union ((union #f string) -> window<%>)
|
|
;;; ((union #f string) (union #f class) -> window<%>)
|
|
;;; ((union #f string) (union class #f) area-container<%> -> area-container<%>))
|
|
;;;; may call error, if no control with the label is found
|
|
(define find-labelled-window
|
|
(case-lambda
|
|
[(label) (find-labelled-window label #f)]
|
|
[(label class) (find-labelled-window label class (get-top-level-focus-window))]
|
|
[(label class window)
|
|
(unless (or (not label)
|
|
(string? label))
|
|
(error 'find-labelled-window "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-window "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-window "third argument must be a area-container<%>, got ~e; other args: ~e ~e"
|
|
window label class))
|
|
(let ([ans
|
|
(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)))
|
|
window]
|
|
[(is-a? window area-container<%>) (ormap loop (send window get-children))]
|
|
[else #f]))])
|
|
(or ans
|
|
(error 'find-labelled-window "no window labelled ~e in ~e~a"
|
|
label
|
|
window
|
|
(if class
|
|
(format " matching class ~e" class)
|
|
""))))])))) |