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

added a search anchor to drschemes new search facility

Browse Source 
svn: r10946
This commit is contained in:
Robby Findler 2008-07-28 18:40:34 +00:00
parent 73d422d542
commit eaf979b749
6 changed files with 176 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

213
collects/framework/private/frame.ss
View File

@ -1730,104 +1730,134 @@
(and frame (and frame
(send frame get-case-sensitive-search?)))) (send frame get-case-sensitive-search?))))
(define/override (on-focus on?)
(when on?
(let ([frame (get-top-level-window)])
(when frame
(let ([text-to-search (send frame get-text-to-search)])
(when text-to-search
(send text-to-search set-search-anchor (send text-to-search get-start-position)))))))
(super on-focus on?))
(define/augment (after-insert x y) (define/augment (after-insert x y)
(update-searching-str) (update-searching-str)
(trigger-jump)
(inner (void) after-insert x y)) (inner (void) after-insert x y))
(define/augment (after-delete x y) (define/augment (after-delete x y)
(update-searching-str) (update-searching-str)
(trigger-jump)
(inner (void) after-delete x y)) (inner (void) after-delete x y))
(define/private (trigger-jump)
(when (preferences:get 'framework:anchored-search)
(let ([frame (get-top-level-window)])
(when frame
(let ([text-to-search (send frame get-text-to-search)])
(when text-to-search
(let ([anchor-pos (send text-to-search get-anchor-pos)])
(when anchor-pos
(send text-to-search begin-edit-sequence)
(send text-to-search set-position anchor-pos anchor-pos)
(search 'forward #t #t #f)
(send text-to-search end-edit-sequence)))))))))
(define/private (get-searching-text) (define/private (get-searching-text)
(let ([frame (get-top-level-window)]) (let ([frame (get-top-level-window)])
(and frame (and frame
(send frame get-text-to-search)))) (send frame get-text-to-search))))
(define/public search (define/public (search [searching-direction 'forward] [beep? #t] [wrap? #t] [move-anchor? #t])
(lambda ([searching-direction 'forward] [beep? #t] [wrap? #t]) (let* ([string (get-text)]
(let* ([string (get-text)] [top-searching-edit (get-searching-text)])
[top-searching-edit (get-searching-text)]) (when top-searching-edit
(when top-searching-edit (let ([searching-edit (let ([focus-snip (send top-searching-edit get-focus-snip)])
(let ([searching-edit (let ([focus-snip (send top-searching-edit get-focus-snip)]) (if focus-snip
(if focus-snip (send focus-snip get-editor)
(send focus-snip get-editor) top-searching-edit))]
top-searching-edit))]
[not-found
[not-found (λ (found-edit skip-beep?)
(λ (found-edit skip-beep?) (when (and beep?
(when (and beep? (not skip-beep?))
(not skip-beep?)) (bell))
(bell)) #f)]
#f)] [found
[found (λ (text first-pos)
(λ (text first-pos) (let ([last-pos ((if (eq? searching-direction 'forward) + -)
(let ([last-pos ((if (eq? searching-direction 'forward) + -) first-pos (string-length string))])
first-pos (string-length string))]) (send text begin-edit-sequence)
(send text begin-edit-sequence) (send text set-caret-owner #f 'display)
(send text set-caret-owner #f 'display) (send text set-position
(send text set-position (min first-pos last-pos)
(min first-pos last-pos) (max first-pos last-pos)
(max first-pos last-pos) #f #f 'local)
#f #f 'local)
;; scroll to the middle if the search result isn't already visible
;; scroll to the middle if the search result isn't already visible (let ([search-result-line (send text position-line (send text get-start-position))]
(let ([search-result-line (send text position-line (send text get-start-position))] [bt (box 0)]
[bt (box 0)] [bb (box 0)])
[bb (box 0)]) (send text get-visible-line-range bt bb #f)
(send text get-visible-line-range bt bb #f) (unless (<= (unbox bt) search-result-line (unbox bb))
(unless (<= (unbox bt) search-result-line (unbox bb)) (let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))]
(let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))] [last-pos (send text position-line (send text last-position))]
[last-pos (send text position-line (send text last-position))] [top-pos (send text line-start-position
[top-pos (send text line-start-position (max (min (- search-result-line half) last-pos) 0))]
(max (min (- search-result-line half) last-pos) 0))] [bottom-pos (send text line-start-position
[bottom-pos (send text line-start-position (max 0
(max 0 (min (+ search-result-line half)
(min (+ search-result-line half) last-pos)))])
last-pos)))]) (send text scroll-to-position
(send text scroll-to-position top-pos
top-pos #f
#f bottom-pos))))
bottom-pos))))
(when move-anchor?
(send text end-edit-sequence) (when (is-a? text text:searching<%>)
(send text set-search-anchor
#t))]) (if (eq? searching-direction 'forward)
(max first-pos last-pos)
(update-searching-str) (min first-pos last-pos)))))
(if (string=? string "") (send text end-edit-sequence)
(not-found top-searching-edit #t)
(let-values ([(found-edit first-pos) #t))])
(find-string-embedded
searching-edit (update-searching-str)
string
searching-direction (if (string=? string "")
(if (eq? 'forward searching-direction) (not-found top-searching-edit #t)
(send searching-edit get-end-position) (let-values ([(found-edit first-pos)
(send searching-edit get-start-position)) (find-string-embedded
'eof #t searching-edit
(get-case-sensitive-search?) string
#t)]) searching-direction
(cond (if (eq? 'forward searching-direction)
[(not first-pos) (send searching-edit get-end-position)
(if wrap? (send searching-edit get-start-position))
(begin 'eof #t
(let-values ([(found-edit pos) (get-case-sensitive-search?)
(find-string-embedded #t)])
top-searching-edit (cond
string [(not first-pos)
searching-direction (if wrap?
(if (eq? 'forward searching-direction) (begin
0 (let-values ([(found-edit pos)
(send searching-edit last-position)) (find-string-embedded
'eof #t top-searching-edit
(get-case-sensitive-search?) string
#f)]) searching-direction
(if (not pos) (if (eq? 'forward searching-direction)
(not-found found-edit #f) 0
(found found-edit pos)))) (send searching-edit last-position))
(not-found found-edit #f))] 'eof #t
[else (get-case-sensitive-search?)
(found found-edit first-pos)])))))))) #f)])
(if (not pos)
(not-found found-edit #f)
(found found-edit pos))))
(not-found found-edit #f))]
[else
(found found-edit first-pos)])))))))
(define callback-queued? #f) (define callback-queued? #f)
(define/private (update-searching-str) (define/private (update-searching-str)
@ -1916,7 +1946,14 @@
(send search/replace-keymap map-function "esc" "hide-search") (send search/replace-keymap map-function "esc" "hide-search")
(send search/replace-keymap add-function "hide-search" (send search/replace-keymap add-function "hide-search"
(λ (text evt) (λ (text evt)
(send (send text get-top-level-window) hide-search))) (let ([tlw (send text get-top-level-window)])
(when (preferences:get 'framework:anchored-search)
(let ([text-to-search (send tlw get-text-to-search)])
(when text-to-search
(let ([anchor-pos (send text-to-search get-anchor-pos)])
(when anchor-pos
(send text-to-search set-position anchor-pos))))))
(send tlw hide-search))))
(define searchable-canvas% (define searchable-canvas%
(class editor-canvas% (class editor-canvas%

2
collects/framework/private/main.ss
View File

@ -20,6 +20,8 @@
(application-preferences-handler (λ () (preferences:show-dialog))) (application-preferences-handler (λ () (preferences:show-dialog)))
(preferences:set-default 'framework:anchored-search #f boolean?)
(let ([search/replace-string-predicate (let ([search/replace-string-predicate
(λ (l) (λ (l)
(and (list? l) (and (list? l)

4
collects/framework/private/preferences.ss
View File

@ -443,6 +443,10 @@ the state transitions / contracts are:
(λ (b) (λ (b)
(if b 'postscript 'standard)) (if b 'postscript 'standard))
(λ (n) (eq? 'postscript n)))) (λ (n) (eq? 'postscript n))))
(make-check editor-panel
'framework:anchored-search
"Anchor based search"
values values)
(editor-panel-procs editor-panel))))]) (editor-panel-procs editor-panel))))])
(add-editor-checkbox-panel))) (add-editor-checkbox-panel)))

33
collects/framework/private/text.ss
View File

@ -207,7 +207,7 @@ WARNING: printf is rebound in the body of the unit to always
[adjust (λ (w f) [adjust (λ (w f)
(+ w (f (case (rectangle-style r) (+ w (f (case (rectangle-style r)
[(ellipse) 8] [(dot ellipse) 8]
[else 0]))))] [else 0]))))]
[this-left (if (number? (rectangle-left r)) [this-left (if (number? (rectangle-left r))
(adjust (rectangle-left r) -) (adjust (rectangle-left r) -)
@ -364,7 +364,12 @@ WARNING: printf is rebound in the body of the unit to always
(unless (or (is-a? color color%) (unless (or (is-a? color color%)
(and (string? color) (and (string? color)
(send the-color-database find-color color))) (send the-color-database find-color color)))
(error 'highlight-range "expected a color or a string in the the-color-database for the third argument, got ~s" color)) (error 'highlight-range "expected a color or a string in the the-color-database for the third argument, got ~e" color))
(unless (memq style '(rectangle ellipse dot))
(error 'highlight-range "expected one of 'rectangle, 'ellipse, or 'dot as the style, got ~e" style))
(when (eq? style 'dot)
(unless (= start end)
(error 'highlight-range "when the style is 'dot, the start and end regions must be the same")))
(let* ([color (if (is-a? color color%) (let* ([color (if (is-a? color color%)
color color
@ -470,6 +475,12 @@ WARNING: printf is rebound in the body of the unit to always
rc]))]) rc]))])
(when color (when color
(case (rectangle-style rectangle) (case (rectangle-style rectangle)
[(dot)
(let ([cx left]
[cy bottom])
(send dc set-pen "black" 1 'transparent)
(send dc set-brush color 'solid)
(send dc draw-ellipse (+ dx cx -3) (+ dy cy -3) 6 6))]
[(ellipse) [(ellipse)
(send dc set-pen color 3 'solid) (send dc set-pen color 3 'solid)
(send dc set-brush "black" 'transparent) (send dc set-brush "black" 'transparent)
@ -593,11 +604,13 @@ WARNING: printf is rebound in the body of the unit to always
(define searching<%> (define searching<%>
(interface (editor:keymap<%> basic<%>) (interface (editor:keymap<%> basic<%>)
set-searching-str set-searching-str
set-search-anchor
get-search-hits)) get-search-hits))
(define searching-mixin (define searching-mixin
(mixin (editor:keymap<%> basic<%>) (searching<%>) (mixin (editor:keymap<%> basic<%>) (searching<%>)
(inherit run-after-edit-sequence invalidate-bitmap-cache) (inherit run-after-edit-sequence invalidate-bitmap-cache
get-start-position)
(define/override (get-keymaps) (define/override (get-keymaps)
(cons (keymap:get-search) (super get-keymaps))) (cons (keymap:get-search) (super get-keymaps)))
@ -605,6 +618,20 @@ WARNING: printf is rebound in the body of the unit to always
(define searching-str #f) (define searching-str #f)
(define case-sensitive? #f) (define case-sensitive? #f)
(define search-hits 0) (define search-hits 0)
(define anchor-pos #f)
(define/public (get-anchor-pos) anchor-pos)
(define clear-anchor void)
(define/public (set-search-anchor position)
(when (preferences:get 'framework:anchored-search)
(clear-anchor)
(set! anchor-pos position)
(set! clear-anchor
(let ([t1 (highlight-range anchor-pos anchor-pos "red" #f 'low 'dot)]
[t2 (highlight-range anchor-pos anchor-pos "red")])
(λ () (t1) (t2))))))
(define/public (get-search-hits) search-hits) (define/public (get-search-hits) search-hits)
(define/public (set-searching-str s [cs? #t]) (define/public (set-searching-str s [cs? #t])

12
collects/scribblings/framework/text.scrbl
View File

@ -12,7 +12,7 @@
(color (or/c string? (is-a?/c color%))) (color (or/c string? (is-a?/c color%)))
(caret-space boolean? #f) (caret-space boolean? #f)
(priority (symbols 'high 'low) 'low) (priority (symbols 'high 'low) 'low)
(style (symbols 'rectangle 'ellipse) 'rectangle)) (style (symbols 'rectangle 'ellipse 'dot) 'rectangle))
(-> void)))]{ (-> void)))]{
This function highlights a region of text in the buffer. This function highlights a region of text in the buffer.
@ -20,7 +20,11 @@
be highlighted with the color in color, if the style is be highlighted with the color in color, if the style is
@scheme['rectangle] (the default). If the style is @scheme['rectangle] (the default). If the style is
@scheme['ellipse], then the outline of an ellipse is @scheme['ellipse], then the outline of an ellipse is
drawn around the range in the editor, using the color. drawn around the range in the editor, using the color.
If the style is @scheme['dot], then @scheme[start] and
@scheme[end] must be the same, and a dot is drawn at the bottom of
that position in the editor.
If @scheme[caret-space?] is not @scheme[#f], the left If @scheme[caret-space?] is not @scheme[#f], the left
edge of the range will be one pixel short, to leave edge of the range will be one pixel short, to leave
@ -232,6 +236,10 @@
Returns the number of hits for the search in the buffer, based on the Returns the number of hits for the search in the buffer, based on the
count found last time that a search happened. count found last time that a search happened.
} }
@defmethod[(set-search-anchor [position number?]) void?]{
Sets the anchor's position in the editor. Only takes effect if
the @scheme['framework:anchored-search] preference is on.
}
} }
@defmixin[text:searching-mixin (editor:keymap<%> text:basic<%>) (text:searching<%>)]{ @defmixin[text:searching-mixin (editor:keymap<%> text:basic<%>) (text:searching<%>)]{
This This

10
collects/tests/drscheme/language-test.ss
View File

@ -1353,11 +1353,11 @@ the settings above should match r5rs
(printf ">> finished ~a\n" (syntax->datum #'arg))))])) (printf ">> finished ~a\n" (syntax->datum #'arg))))]))
(define (run-test) (define (run-test)
(go pretty-big) ;(go pretty-big)
(go r5rs) (go r5rs)
(go beginner) ;(go beginner)
(go beginner/abbrev) ;(go beginner/abbrev)
(go intermediate) ;(go intermediate)
(go intermediate/lambda) ;(go intermediate/lambda)
(go advanced) (go advanced)
) )