127 lines
5.1 KiB
Racket
127 lines
5.1 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/gui/base
|
|
racket/class
|
|
framework/test)
|
|
(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 (test:get-active-top-level-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 (test:get-active-top-level-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 '()])))
|
|
|
|
|