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

adjusted searching a little bit

Browse Source 
svn: r11072

original commit: 8d53a2ec34ff601eac94a6a34119db1a35c64f87
This commit is contained in:
Robby Findler 2008-08-04 20:19:10 +00:00
parent 9d7fb17332
commit 4acfa8e9cb
3 changed files with 52 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1730,13 +1730,25 @@
(and frame (and frame
(send frame get-case-sensitive-search?)))) (send frame get-case-sensitive-search?))))
(define/override (on-focus on?) ;; search-yellow : (or/c #f (-> void))
(when on? ;; if #f, that means the editor does not have the focus
(let ([frame (get-top-level-window)]) ;; if a function, then this is a callback that removes the yellow
(when frame ;; highlighting from the text-to-search (if any).
(let ([text-to-search (send frame get-text-to-search)]) (define search-yellow #f)
(when text-to-search
(send text-to-search set-search-anchor (send text-to-search get-start-position))))))) (define/override (on-focus on?)
(let ([frame (get-top-level-window)])
(when frame
(let ([text-to-search (send frame get-text-to-search)])
(when text-to-search
(cond
[on?
(set! search-yellow void)
(send text-to-search set-search-anchor (send text-to-search get-start-position))]
[else
(when search-yellow
(search-yellow)
(set! search-yellow #f))])))))
(super on-focus on?)) (super on-focus on?))
(define/augment (after-insert x y) (define/augment (after-insert x y)
@ -1783,14 +1795,13 @@
#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))]
[start-pos (min first-pos last-pos)]
[end-pos (max first-pos last-pos)])
(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 start-pos end-pos #f #f 'local)
(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 ;; scroll to the middle if the search result isn't already visible
@ -1812,12 +1823,17 @@
#f #f
bottom-pos)))) bottom-pos))))
(when search-yellow
(search-yellow)
(set! search-yellow
(send text highlight-range start-pos end-pos "khaki" #f 'low 'ellipse)))
(when move-anchor? (when move-anchor?
(when (is-a? text text:searching<%>) (when (is-a? text text:searching<%>)
(send text set-search-anchor (send text set-search-anchor
(if (eq? searching-direction 'forward) (if (eq? searching-direction 'forward)
(max first-pos last-pos) end-pos
(min first-pos last-pos))))) start-pos))))
(send text end-edit-sequence) (send text end-edit-sequence)
@ -1874,20 +1890,16 @@
(define/public (text-to-search-changed old new) (define/public (text-to-search-changed old new)
(when old (when old
(for-each
(λ (canvas) (send canvas force-display-focus #f))
(send old get-canvases))
(send old set-searching-str #f)) (send old set-searching-str #f))
(when new (when new
(for-each
(λ (canvas) (send canvas force-display-focus #t))
(send new get-canvases))
(update-searching-str/cs new (get-case-sensitive-search?)))) (update-searching-str/cs new (get-case-sensitive-search?))))
(define/public (case-sensitivity-changed) (define/public (case-sensitivity-changed)
(update-searching-str)) (update-searching-str))
(define/private (update-searching-str/cs txt cs?) (define/private (update-searching-str/cs txt cs?)
(when search-yellow
(search-yellow))
(let ([str (get-text)]) (let ([str (get-text)])
(send txt set-searching-str (send txt set-searching-str
(if (equal? str "") #f str) (if (equal? str "") #f str)

23
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)
[(dot ellipse) 8] [(dot hollow-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) -)
@ -273,12 +273,9 @@ WARNING: printf is rebound in the body of the unit to always
style style
color) color)
rst)] rst)]
[(eq? style 'ellipse) [(or (eq? style 'hollow-ellipse)
(eq? style 'ellipse))
(let ([end-line (position-line end end-eol?)]) (let ([end-line (position-line end end-eol?)])
;; for this loop,
;; we don't need to consider the first or the last line,
;; since they are already covered
;; by `start-x' and `end-x'
(let loop ([l (min start-x end-x)] (let loop ([l (min start-x end-x)]
[r (max start-x end-x)] [r (max start-x end-x)]
[line (position-line start start-eol?)]) [line (position-line start start-eol?)])
@ -365,8 +362,8 @@ WARNING: printf is rebound in the body of the unit to always
(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 ~e" 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)) (unless (memq style '(rectangle hollow-ellipse ellipse dot))
(error 'highlight-range "expected one of 'rectangle, 'ellipse, or 'dot as the style, got ~e" style)) (error 'highlight-range "expected one of 'rectangle, 'ellipse 'hollow-ellipse, or 'dot as the style, got ~e" style))
(when (eq? style 'dot) (when (eq? style 'dot)
(unless (= start end) (unless (= start end)
(error 'highlight-range "when the style is 'dot, the start and end regions must be the same"))) (error 'highlight-range "when the style is 'dot, the start and end regions must be the same")))
@ -481,7 +478,7 @@ WARNING: printf is rebound in the body of the unit to always
(send dc set-pen "black" 1 'transparent) (send dc set-pen "black" 1 'transparent)
(send dc set-brush color 'solid) (send dc set-brush color 'solid)
(send dc draw-ellipse (+ dx cx -3) (+ dy cy -3) 6 6))] (send dc draw-ellipse (+ dx cx -3) (+ dy cy -3) 6 6))]
[(ellipse) [(hollow-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)
(send dc draw-ellipse (send dc draw-ellipse
@ -492,7 +489,11 @@ WARNING: printf is rebound in the body of the unit to always
[(rectangle) [(rectangle)
(send dc set-pen color 1 'transparent) (send dc set-pen color 1 'transparent)
(send dc set-brush color 'solid) (send dc set-brush color 'solid)
(send dc draw-rectangle (+ left dx) (+ top dy) width height)]))))))]) (send dc draw-rectangle (+ left dx) (+ top dy) width height)]
[(ellipse)
(send dc set-pen color 1 'transparent)
(send dc set-brush color 'solid)
(send dc draw-ellipse (+ left dx) (+ top dy) width height)]))))))])
(send dc set-smoothing 'aligned) (send dc set-smoothing 'aligned)
(for-each color-rectangle range-rectangles) (for-each color-rectangle range-rectangles)
(send dc set-smoothing old-smoothing) (send dc set-smoothing old-smoothing)
@ -703,7 +704,7 @@ WARNING: printf is rebound in the body of the unit to always
searching-str)]) searching-str)])
(set! search-hits (+ search-hits counts)) (set! search-hits (+ search-hits counts))
(let ([old clear-regions] (let ([old clear-regions]
[new (highlight-range next end "plum" #f 'low 'ellipse)]) [new (highlight-range next end "plum" #f 'low 'hollow-ellipse)])
(set! clear-regions (λ () (old) (new)))) (set! clear-regions (λ () (old) (new))))
(loop end (+ n 1))))))] (loop end (+ n 1))))))]
[else [else

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

@ -12,14 +12,17 @@
(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 'dot) 'rectangle)) (style (symbols 'rectangle 'ellipse 'hollow-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.
The range between @scheme[start] and @scheme[end] will The range between @scheme[start] and @scheme[end] will
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).
@scheme['ellipse], then the outline of an ellipse is If the style is @scheme['ellipse], then an ellipse is drawn
around the range in the editor, using the color.
If the style is
@scheme['hollow-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 If the style is @scheme['dot], then @scheme[start] and
@ -53,7 +56,7 @@
(end exact-nonnegative-integer?) (end exact-nonnegative-integer?)
(color (or/c string? (is-a?/c color%))) (color (or/c string? (is-a?/c color%)))
(caret-space boolean? #f) (caret-space boolean? #f)
(style (symbols 'rectangle 'ellipse) 'rectangle)) (style (symbols 'rectangle 'ellipse 'hollow-ellipse) 'rectangle))
void))]{ void))]{
This method removes the highlight from a region of text in This method removes the highlight from a region of text in
the buffer. the buffer.