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

rackety & add test suite

Browse Source
This commit is contained in:
Robby Findler 2016-07-24 03:41:03 -05:00
parent feaff67418
commit 6b16c0fd6b
1 changed files with 155 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

250
gui-lib/framework/private/search.rkt
View File

@ -1,99 +1,159 @@
#lang scheme/base #lang racket/base
(require racket/contract/base (require racket/contract/base
racket/class racket/class
scheme/gui/base) racket/gui/base)
(provide/contract (provide
[find-string-embedded (contract-out
(->* ((is-a?/c text%) [find-string-embedded
string?) (->* ((is-a?/c text%)
((symbols 'forward 'backward) string?)
(or/c (symbols 'start) number?) ((or/c 'forward 'backward)
(or/c (symbols 'eof) number?) (or/c 'start number?)
boolean? (or/c 'eof number?)
boolean? boolean?
boolean?) boolean?
(values (is-a?/c editor<%>) boolean?)
(or/c false/c number?)))]) (values (is-a?/c editor<%>)
(or/c #f number?)))]))
(define find-string-embedded (define (find-string-embedded a-text
(lambda (edit str
str [direction 'forward]
[direction 'forward] [_start 'start]
[start 'start] [_end 'eof]
[end 'eof] [get-start #t]
[get-start #t] [case-sensitive? #t]
[case-sensitive? #t] [pop-out? #f])
[pop-out? #f]) (define start
(let/ec k (if (eq? _start 'start)
(let* ([start (if (eq? start 'start) (send a-text get-start-position)
(send edit get-start-position) _start))
start)] (define end
[end (if (eq? 'eof end) (if (eq? 'eof _end)
(if (eq? direction 'forward) (if (eq? direction 'forward)
(send edit last-position) (send a-text last-position)
0) 0)
end)] end))
[flat (send edit find-string str direction (define flat (send a-text find-string str direction
start end get-start start end get-start
case-sensitive?)] case-sensitive?))
[pop-out (define (pop-out)
(λ () (define admin (send a-text get-admin))
(let ([admin (send edit get-admin)]) (cond
(if (is-a? admin editor-snip-editor-admin<%>) [(is-a? admin editor-snip-editor-admin<%>)
(let* ([snip (send admin get-snip)] (define snip (send admin get-snip))
[edit-above (send (send snip get-admin) get-editor)] (define edit-above (send (send snip get-admin) get-editor))
[pos (send edit-above get-snip-position snip)] (define pos (send edit-above get-snip-position snip))
[pop-out-pos (if (eq? direction 'forward) (add1 pos) pos)]) (define pop-out-pos (if (eq? direction 'forward) (add1 pos) pos))
(find-string-embedded (find-string-embedded
edit-above edit-above
str str
direction direction
pop-out-pos pop-out-pos
(if (eq? direction 'forward) 'eof 0) (if (eq? direction 'forward) 'eof 0)
get-start get-start
case-sensitive? case-sensitive?
pop-out?)) pop-out?)]
(values edit #f))))]) [else (values a-text #f)]))
(let loop ([current-snip (send edit find-snip start (let loop ([current-snip (send a-text find-snip start
(if (eq? direction 'forward) (if (eq? direction 'forward)
'after-or-none 'after-or-none
'before-or-none))]) 'before-or-none))])
(let ([next-loop (define (next-loop)
(λ () (if (eq? direction 'forward)
(if (eq? direction 'forward) (loop (send current-snip next))
(loop (send current-snip next)) (loop (send current-snip previous))))
(loop (send current-snip previous))))]) (cond
(cond [(or (not current-snip)
[(or (not current-snip) (and flat
(and flat (let* ([start (send a-text get-snip-position current-snip)]
(let* ([start (send edit get-snip-position current-snip)] [end (+ start (send current-snip get-count))])
[end (+ start (send current-snip get-count))]) (if (equal? direction 'forward)
(if (eq? direction 'forward) (and (<= start flat)
(and (<= start flat) (< flat end))
(< flat end)) (and (< start flat)
(and (< start flat) (<= flat end))))))
(<= flat end)))))) (if (and (not flat) pop-out?)
(if (and (not flat) pop-out?) (pop-out)
(pop-out) (values a-text flat))]
(values edit flat))] [(is-a? current-snip editor-snip%)
[(is-a? current-snip editor-snip%) (define media (send current-snip get-editor))
(let-values ([(embedded embedded-pos) (define-values (embedded embedded-pos)
(let ([media (send current-snip get-editor)]) (cond
(if (and media [(and media (is-a? media text%))
(is-a? media text%)) (find-string-embedded
(begin media
(find-string-embedded str
media direction
str (if (eq? 'forward direction)
direction 0
(if (eq? 'forward direction) (send media last-position))
0 'eof
(send media last-position)) get-start case-sensitive?)]
'eof [else
get-start case-sensitive?)) (values #f #f)]))
(values #f #f)))]) (if (not embedded-pos)
(if (not embedded-pos) (next-loop)
(next-loop) (values embedded embedded-pos))]
(values embedded embedded-pos)))] [else (next-loop)])))
[else (next-loop)])))))))
(module+ test
(require rackunit)
(define abcX (new text%))
(send abcX insert "abcX")
(define abc/abcX/abcQ (new text%))
(send abc/abcX/abcQ insert "abc")
(send abc/abcX/abcQ insert (new editor-snip% [editor abcX]))
(send abc/abcX/abcQ insert "abcQ")
(define abc//abc/abcX/abcQ//abcZ (new text%))
(send abc//abc/abcX/abcQ//abcZ insert "abc")
(send abc//abc/abcX/abcQ//abcZ insert (new editor-snip% [editor abc/abcX/abcQ]))
(send abc//abc/abcX/abcQ//abcZ insert "abcZ")
(let ()
(define-values (ta pos) (find-string-embedded abcX "b" 'forward 0))
(check-equal? ta abcX)
(check-equal? pos 1))
(let ()
(define-values (ta pos) (find-string-embedded abcX "c" 'forward 0))
(check-equal? ta abcX)
(check-equal? pos 2))
(let ()
(define-values (ta pos) (find-string-embedded abcX "d" 'forward 2))
(check-equal? pos #f))
(let ()
(define-values (ta pos) (find-string-embedded abc/abcX/abcQ "b" 'forward 0))
(check-equal? ta ta)
(check-equal? pos 1))
(let ()
(define-values (ta pos) (find-string-embedded abc/abcX/abcQ "b" 'forward 2))
(check-equal? ta abcX)
(check-equal? pos 1))
(let ()
(define-values (ta pos) (find-string-embedded abc//abc/abcX/abcQ//abcZ "X" 'forward 0))
(check-equal? ta abcX)
(check-equal? pos 3))
(let ()
(define-values (ta pos) (find-string-embedded abcX "Q" 'forward 0 'eof #t #t #t))
(check-equal? ta abc/abcX/abcQ)
(check-equal? pos 7))
(let ()
(define-values (ta pos) (find-string-embedded abcX "Z" 'forward 0 'eof #t #t #t))
(check-equal? ta abc//abc/abcX/abcQ//abcZ)
(check-equal? pos 7))
(let ()
(define-values (ta pos) (find-string-embedded abcX "c" 'forward 4 'eof #t #t #t))
(check-equal? ta abc/abcX/abcQ)
(check-equal? pos 6)))