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

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

@ -1730,19 +1730,42 @@
(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])
(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
@ -1788,6 +1811,13 @@
#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))])
@ -1827,7 +1857,7 @@
(found found-edit pos))))
(not-found found-edit #f))]
[else
(found found-edit first-pos)]))))))))
(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])

10
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.
@ -22,6 +22,10 @@
@scheme['ellipse], then the outline of an ellipse is
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
space for the caret. The caret does not interfere with
@ -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)
)