added a search anchor to drschemes new search facility

svn: r10946

collects/framework/private/frame.ss

@@ -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
+    (define/public (search [searching-direction 'forward] [beep? #t] [wrap? #t] [move-anchor? #t])
-      (lambda ([searching-direction 'forward] [beep? #t] [wrap? #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% 

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)

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)))
   

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])

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.
 
@@ -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 

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)
-  (go beginner/abbrev)
+  ;(go beginner/abbrev)
-  (go intermediate)
+  ;(go intermediate)
-  (go intermediate/lambda)
+  ;(go intermediate/lambda)
   (go advanced)
   )