From eaf979b749b6e5aee330a3aa7d82e8d605effb24 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 28 Jul 2008 18:40:34 +0000 Subject: [PATCH] added a search anchor to drschemes new search facility svn: r10946 --- collects/framework/private/frame.ss | 213 +++++++++++++--------- collects/framework/private/main.ss | 2 + collects/framework/private/preferences.ss | 4 + collects/framework/private/text.ss | 33 +++- collects/scribblings/framework/text.scrbl | 12 +- collects/tests/drscheme/language-test.ss | 10 +- 6 files changed, 176 insertions(+), 98 deletions(-) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 10692ed85e..a4623d989f 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -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% diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index 07c47c17af..8b7064f72d 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -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) diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 6dff796a37..a0dae8c81f 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -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))) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 37d781162e..2219169b52 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -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]) diff --git a/collects/scribblings/framework/text.scrbl b/collects/scribblings/framework/text.scrbl index 665dad2e8b..6c7b4562ce 100644 --- a/collects/scribblings/framework/text.scrbl +++ b/collects/scribblings/framework/text.scrbl @@ -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 diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss index 62d4ed46ca..678426e139 100644 --- a/collects/tests/drscheme/language-test.ss +++ b/collects/tests/drscheme/language-test.ss @@ -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) )