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

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

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

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

@ -443,6 +443,10 @@ the state transitions / contracts are:
(λ (b)
(if b 'postscript 'standard))
(λ (n) (eq? 'postscript n))))
(make-check editor-panel
'framework:anchored-search
"Anchor based search"
values values)
(editor-panel-procs editor-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)
(+ w (f (case (rectangle-style r)
[(ellipse) 8]
[(dot ellipse) 8]
[else 0]))))]
[this-left (if (number? (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%)
(and (string? 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%)
color
@ -470,6 +475,12 @@ WARNING: printf is rebound in the body of the unit to always
rc]))])
(when color
(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)
(send dc set-pen color 3 'solid)
(send dc set-brush "black" 'transparent)
@ -593,11 +604,13 @@ WARNING: printf is rebound in the body of the unit to always
(define searching<%>
(interface (editor:keymap<%> basic<%>)
set-searching-str
set-search-anchor
get-search-hits))
(define searching-mixin
(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)
(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 case-sensitive? #f)
(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 (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%)))
(caret-space boolean? #f)
(priority (symbols 'high 'low) 'low)
(style (symbols 'rectangle 'ellipse) 'rectangle))
(style (symbols 'rectangle 'ellipse 'dot) 'rectangle))
(-> void)))]{
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
@scheme['rectangle] (the default). If the style 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
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
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<%>)]{
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))))]))
(define (run-test)
(go pretty-big)
;(go pretty-big)
(go r5rs)
(go beginner)
(go beginner/abbrev)
(go intermediate)
(go intermediate/lambda)
;(go beginner)
;(go beginner/abbrev)
;(go intermediate)
;(go intermediate/lambda)
(go advanced)
)