adjusted searching a little bit
svn: r11072 original commit: 8d53a2ec34ff601eac94a6a34119db1a35c64f87
This commit is contained in:
Robby Findler
parent
9d7fb17332
commit
4acfa8e9cb
|
|
@ -1730,13 +1730,25 @@
|
|||
(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)))))))
|
||||
;; search-yellow : (or/c #f (-> void))
|
||||
;; if #f, that means the editor does not have the focus
|
||||
;; if a function, then this is a callback that removes the yellow
|
||||
;; highlighting from the text-to-search (if any).
|
||||
(define search-yellow #f)
|
||||
|
||||
(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?))
|
||||
|
||||
(define/augment (after-insert x y)
|
||||
|
|
@ -1783,14 +1795,13 @@
|
|||
#f)]
|
||||
[found
|
||||
(λ (text first-pos)
|
||||
(let ([last-pos ((if (eq? searching-direction 'forward) + -)
|
||||
first-pos (string-length string))])
|
||||
(let* ([last-pos ((if (eq? searching-direction 'forward) + -)
|
||||
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 set-caret-owner #f 'display)
|
||||
(send text set-position
|
||||
(min first-pos last-pos)
|
||||
(max first-pos last-pos)
|
||||
#f #f 'local)
|
||||
(send text set-position start-pos end-pos #f #f 'local)
|
||||
|
||||
|
||||
;; scroll to the middle if the search result isn't already visible
|
||||
|
|
@ -1812,12 +1823,17 @@
|
|||
#f
|
||||
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 (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)))))
|
||||
end-pos
|
||||
start-pos))))
|
||||
|
||||
(send text end-edit-sequence)
|
||||
|
||||
|
|
@ -1874,20 +1890,16 @@
|
|||
|
||||
(define/public (text-to-search-changed old new)
|
||||
(when old
|
||||
(for-each
|
||||
(λ (canvas) (send canvas force-display-focus #f))
|
||||
(send old get-canvases))
|
||||
(send old set-searching-str #f))
|
||||
(when new
|
||||
(for-each
|
||||
(λ (canvas) (send canvas force-display-focus #t))
|
||||
(send new get-canvases))
|
||||
(update-searching-str/cs new (get-case-sensitive-search?))))
|
||||
|
||||
(define/public (case-sensitivity-changed)
|
||||
(update-searching-str))
|
||||
|
||||
(define/private (update-searching-str/cs txt cs?)
|
||||
(when search-yellow
|
||||
(search-yellow))
|
||||
(let ([str (get-text)])
|
||||
(send txt set-searching-str
|
||||
(if (equal? str "") #f str)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
[(dot ellipse) 8]
|
||||
[(dot hollow-ellipse) 8]
|
||||
[else 0]))))]
|
||||
[this-left (if (number? (rectangle-left r))
|
||||
(adjust (rectangle-left r) -)
|
||||
|
|
@ -273,12 +273,9 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
style
|
||||
color)
|
||||
rst)]
|
||||
[(eq? style 'ellipse)
|
||||
[(or (eq? style 'hollow-ellipse)
|
||||
(eq? style 'ellipse))
|
||||
(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)]
|
||||
[r (max start-x end-x)]
|
||||
[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)
|
||||
(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))
|
||||
(unless (memq style '(rectangle ellipse dot))
|
||||
(error 'highlight-range "expected one of 'rectangle, 'ellipse, or 'dot as the style, got ~e" style))
|
||||
(unless (memq style '(rectangle hollow-ellipse ellipse dot))
|
||||
(error 'highlight-range "expected one of 'rectangle, 'ellipse 'hollow-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")))
|
||||
|
|
@ -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-brush color 'solid)
|
||||
(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-brush "black" 'transparent)
|
||||
(send dc draw-ellipse
|
||||
|
|
@ -492,7 +489,11 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
[(rectangle)
|
||||
(send dc set-pen color 1 'transparent)
|
||||
(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)
|
||||
(for-each color-rectangle range-rectangles)
|
||||
(send dc set-smoothing old-smoothing)
|
||||
|
|
@ -703,7 +704,7 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
searching-str)])
|
||||
(set! search-hits (+ search-hits counts))
|
||||
(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))))
|
||||
(loop end (+ n 1))))))]
|
||||
[else
|
||||
|
|
|
|||
|
|
@ -12,14 +12,17 @@
|
|||
(color (or/c string? (is-a?/c color%)))
|
||||
(caret-space boolean? #f)
|
||||
(priority (symbols 'high 'low) 'low)
|
||||
(style (symbols 'rectangle 'ellipse 'dot) 'rectangle))
|
||||
(style (symbols 'rectangle 'ellipse 'hollow-ellipse 'dot) 'rectangle))
|
||||
(-> void)))]{
|
||||
This function highlights a region of text in the buffer.
|
||||
|
||||
The range between @scheme[start] and @scheme[end] will
|
||||
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
|
||||
@scheme['rectangle] (the default).
|
||||
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.
|
||||
|
||||
If the style is @scheme['dot], then @scheme[start] and
|
||||
|
|
@ -53,7 +56,7 @@
|
|||
(end exact-nonnegative-integer?)
|
||||
(color (or/c string? (is-a?/c color%)))
|
||||
(caret-space boolean? #f)
|
||||
(style (symbols 'rectangle 'ellipse) 'rectangle))
|
||||
(style (symbols 'rectangle 'ellipse 'hollow-ellipse) 'rectangle))
|
||||
void))]{
|
||||
This method removes the highlight from a region of text in
|
||||
the buffer.
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user