diff --git a/collects/tests/utils/gui.ss b/collects/tests/utils/gui.ss index dc607171..d5b89c91 100644 --- a/collects/tests/utils/gui.ss +++ b/collects/tests/utils/gui.ss @@ -1,6 +1,42 @@ -(require-library "guis.ss" "tests" "utils") +(module gui mzscheme + (require (lib "mred.ss" "mred")) + (provide find-labelled-window) -(define-values/invoke-unit/sig test-utils:gui^ - (require-library "guir.ss" "tests" "utils") - #f - mred^) \ No newline at end of file + ;;; 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) + ""))))])))) \ No newline at end of file