improve the situation for search results in nested editors

This doesn't quite fix all the problems, as the outer editor doesn't get callbacks
when the position changes in the inner editors (and the inner ones aren't propogating
the callbacks currently) so the "n/m matches" display doesn't update properly in that
case. Also, it doesn't (yet) try to draw the search bubbles for embedded editors

Still, progress has been made; at least the bar is not red anymore when there are
hits only in embedded editors

closes PR 12786

gui-lib/framework/private/text.rkt

@@ -1138,7 +1138,7 @@
              get-start-position get-end-position
              unhighlight-ranges/key unhighlight-range highlight-range
              run-after-edit-sequence begin-edit-sequence end-edit-sequence
-             find-string get-admin position-line
+             find-string find-string-embedded get-admin position-line
              in-edit-sequence? get-pos/text-dc-location
              get-canvas get-top-level-window)
     
@@ -1271,7 +1271,7 @@
                 (define next (do-search (get-start-position) 'eof))
                 (begin-edit-sequence #t #f)
                 (cond
-                  [next
+                  [(number? next)
                    (unless (and to-replace-highlight
                                 (= (car to-replace-highlight) next)
                                 (= (cdr to-replace-highlight) 
@@ -1294,17 +1294,28 @@
         (queue-callback
          (λ ()
            (when searching-str
-             (define count 0)
+             (define start-pos (get-focus-editor-start-position))
-             (define start-pos (get-start-position))
+             (define count
-             (hash-for-each
+               (for/sum ([(k v) (in-hash search-bubble-table)])
-              search-bubble-table
+                 (define n (if (search-result-compare <= (car k) start-pos) 1 0))
-              (λ (k v)
+                 n))
-                (when (<= (car k) start-pos)
-                  (set! count (+ count 1)))))
              (update-before-caret-search-hit-count count))
            (set! search-position-callback-running? #f))
          #f)))
 
+    (define/private (get-focus-editor-start-position)
+      (let loop ([txt this])
+        (define focus (send txt get-focus-snip))
+        (define embedded
+          (and focus
+               (is-a? focus editor-snip%)
+               (is-a? (send focus get-editor) text%)
+               (send focus get-editor)))
+        (cond
+          [embedded
+           (cons embedded (loop embedded))]
+          [else (send txt get-start-position)])))
+    
     (define/private (update-before-caret-search-hit-count c)
       (unless (equal? before-caret-search-hit-count c)
         (set! before-caret-search-hit-count c)
@@ -1330,7 +1341,7 @@
               (clear-yellow)
               (set! clear-yellow void)
               (when (and searching-str (= (string-length searching-str) (- end start)))
-                (when (do-search start end)
+                (when (find-string searching-str 'forward start end #t case-sensitive?)
                   (set! clear-yellow (highlight-range
                                       start end
                                       (if (preferences:get 'framework:white-on-black?)
@@ -1349,7 +1360,7 @@
             (list (list to-replace-highlight 'dark-search-color))
             (list))
         (hash-map search-bubble-table
-                  (λ (x true) 
+                  (λ (x _true)
                     (list x (if replace-mode? 'light-search-color 'normal-search-color)))))
        string<?
        #:key (λ (x) (format "~s" (car x)))))
@@ -1414,31 +1425,40 @@
         [searching-str
          (define new-search-bubbles '())
          (define new-replace-bubble #f)
-         (define first-hit (do-search 0 'eof))
+         (define first-hit (do-search 0))
+         
          (define-values (this-search-hit-count this-before-caret-search-hit-count)
            (cond
              [first-hit
-              (define sp (get-start-position))
+              (define sp (get-focus-editor-start-position))
               (let loop ([bubble-start first-hit]
                          [search-hit-count 0]
-                         [before-caret-search-hit-count 1])
+                         [before-caret-search-hit-count (if (search-result-compare < first-hit sp) 1 0)])
                 (maybe-pause)
-                (define bubble-end (+ bubble-start (string-length searching-str)))
+                (define bubble-end (search-result+ bubble-start (string-length searching-str)))
-                (define bubble (cons bubble-start bubble-end))
+                (define bubble (cons bubble-start (string-length searching-str)))
                 (define this-bubble
                   (cond
                     [(and replace-mode?
                           (not new-replace-bubble)
-                          (<= sp bubble-start))
+                          (search-result-compare <= sp bubble-start))
                      (set! new-replace-bubble bubble)
                      'the-replace-bubble]
                     [else
                      bubble]))
                 (set! new-search-bubbles (cons this-bubble new-search-bubbles))
 
-                (define next (do-search bubble-end 'eof))
+                (define next (do-search bubble-end))
+
+                (when (> (let loop ([x bubble-start])
+                           (cond
+                             [(number? x) 1]
+                             [else (+ 1 (loop (cdr x)))]))
+                         3)
+                  (car))
+                
                 (define next-before-caret-search-hit-count
-                  (if (and next (< next sp))
+                  (if (and next (search-result-compare < next sp))
                       (+ 1 before-caret-search-hit-count)
                       before-caret-search-hit-count))
                 (cond
@@ -1489,14 +1509,78 @@
                [(is-a? w area<%>)
                 (loop (send w get-parent))]))))))
 
+    (define/private (search-result+ search-result num)
+      (let loop ([search-result search-result])
+        (cond
+          [(number? search-result) (+ search-result num)]
+          [(cons? search-result)
+           (cons (car search-result)
+                 (loop (cdr search-result)))])))
+
+    (define/private (search-result-compare lt l r)
+      (let loop ([txt this]
+                 [l l]
+                 [r r])
+        (define (get-the-position x)
+          ;; the zeros shouldn't happen because the editors should still
+          ;; be in the main text object while we are doing stuff with them
+          (define admin (send x get-admin))
+          (cond
+            [(is-a? admin editor-snip-editor-admin<%>)
+             (or (send txt get-snip-position (send admin get-snip)) 0)]
+            [else
+             0]))
+        (cond
+          [(and (number? l) (number? r)) (lt l r)]
+          [(or (number? l) (number? r))
+           (define ln (if (number? l) l (get-the-position (car l))))
+           (define rn (if (number? r) r (get-the-position (car r))))
+           (lt ln rn)]
+          [else
+           (cond
+             [(equal? (car l) (car r))
+              (loop (car l) (cdr l) (cdr r))]
+             [else
+              (lt (get-the-position (car l))
+                  (get-the-position (car r)))])])))
+    
     (define/private (clear-all-regions) 
       (when to-replace-highlight 
         (unhighlight-replace))
       (unhighlight-ranges/key 'plt:framework:search-bubbles)
       (set! search-bubble-table (make-hash)))
     
-    (define/private (do-search start end)
+    (define/private (do-search start)
-      (find-string searching-str 'forward start end #t case-sensitive?))
+      (define context (list this))
+      (define position
+        (let loop ([start start])
+          (cond
+            [(number? start) start]
+            [else
+             (set! context (cons (car start) context))
+             (loop (cdr start))])))
+      (let loop ([position position]
+                 [context context])
+        (define found-at-this-level
+          (send (car context) find-string-embedded searching-str 'forward position 'eof #t case-sensitive?))
+        (cond
+          [found-at-this-level
+           (let loop ([context context])
+             (cond
+               [(null? (cdr context)) found-at-this-level]
+               [else (cons (car context)
+                           (loop (cdr context)))]))]
+          [(null? (cdr context)) #f]
+          [else
+           (define admin (send (car context) get-admin))
+           (cond
+             [(is-a? admin editor-snip-editor-admin<%>)
+              (define snip (send admin get-snip))
+              (loop (+ (send (second context) get-snip-position snip)
+                       (send snip get-count))
+                    (cdr context))]
+             [else
+              (error 'framework/private/text.rkt::searching "admin went wrong ~s" admin)])])))
     
     ;; INVARIANT: when a search bubble is highlighted,
     ;; the search-bubble-table has it mapped to #t
@@ -1506,40 +1590,57 @@
     
     ;; this method may be called with bogus inputs (ie a pair that has no highlight)
     ;; but only when there is a pending "erase all highlights and recompute everything" callback
-    (define/private (unhighlight-hit pair)
+    (define/private (unhighlight-hit bubble)
-      (hash-remove! search-bubble-table pair)
+      (hash-remove! search-bubble-table bubble)
-      (unhighlight-range (car pair) (cdr pair) 
+      (define-values (txt start end) (get-highlighting-text-and-range bubble))
+      (when txt
+        (send txt unhighlight-range
+              start end
               (if replace-mode? light-search-color normal-search-color)
               #f
-                         'hollow-ellipse))
+              'hollow-ellipse)))
-    (define/private (highlight-hit pair)
+    (define/private (highlight-hit bubble)
-      (hash-set! search-bubble-table pair #t)
+      (hash-set! search-bubble-table bubble #t)
-      (highlight-range (car pair) (cdr pair) 
+      (define-values (txt start end) (get-highlighting-text-and-range bubble))
+      (when txt
+        (send txt highlight-range
+              start end
               (if replace-mode? light-search-color normal-search-color)
               #f
               'low
               'hollow-ellipse
               #:key 'plt:framework:search-bubbles
-                       #:adjust-on-insert/delete? #t))
+              #:adjust-on-insert/delete? #t)))
     
     ;; INVARIANT: the "next to replace" highlight is always
     ;; saved in 'to-replace-highlight'
     (define/private (unhighlight-replace)
-      (unhighlight-range (car to-replace-highlight)
+      (define-values (txt start end) (get-highlighting-text-and-range to-replace-highlight))
-                         (cdr to-replace-highlight)
+      (when txt
+        (send txt unhighlight-range
+              start end
               dark-search-color
               #f
-                         'hollow-ellipse)
+              'hollow-ellipse))
       (set! to-replace-highlight #f))
     
     (define/private (highlight-replace new-to-replace)
       (set! to-replace-highlight new-to-replace)
-      (highlight-range (car to-replace-highlight)
+      (define-values (txt start end) (get-highlighting-text-and-range new-to-replace))
-                       (cdr to-replace-highlight)
+      (when txt
+        (send txt highlight-range
+              start end
               dark-search-color
               #f
               'high
-                       'hollow-ellipse))
+              'hollow-ellipse)))
+
+    (define/private (get-highlighting-text-and-range bubble)
+      (cond
+        [(number? (car bubble))
+         (values this (car bubble) (+ (car bubble) (cdr bubble)))]
+        [else
+         (values #f #f #f)]))
     
     (define/private (unhighlight-anchor)
       (unhighlight-range anchor-pos anchor-pos "red" #f 'dot)

gui-test/framework/tests/test-suite-utils.rkt

@@ -14,7 +14,7 @@
  
  load-framework-automatically
  shutdown-listener shutdown-mred mred-running?
- send-sexp-to-mred queue-sexp-to-mred
+ send-sexp-to-mred send-sexp-to-mred/separate-thread queue-sexp-to-mred
  test
  wait-for-frame
  
@@ -52,7 +52,7 @@
 
 (module local-namespace racket/base
   (require racket/gui/base)
-  (provide send-sexp-to-mred
+  (provide send-sexp-to-mred send-sexp-to-mred/separate-thread
            queue-sexp-to-mred
            eof-result?
            shutdown-listener shutdown-mred mred-running?
@@ -76,6 +76,13 @@
           (eval sexp)))))
     (channel-get c))
 
+  (define (send-sexp-to-mred/separate-thread sexp)
+    (unless ns?
+      (namespace-require 'framework)
+      (namespace-require 'racket/gui/base)
+      (set! ns? #t))
+    (eval sexp))
+
   (define queue-sexp-to-mred send-sexp-to-mred)
 
   (define (eof-result? x)
@@ -120,7 +127,7 @@
            "debug.rkt"
            racket/tcp
            racket/pretty)
-  (provide send-sexp-to-mred
+  (provide send-sexp-to-mred send-sexp-to-mred/separate-thread
            queue-sexp-to-mred
            eof-result?
            shutdown-listener shutdown-mred mred-running?
@@ -272,6 +279,9 @@
                 [(normal) 
                  (eval (list-ref answer 1))]))))))
 
+  (define (send-sexp-to-mred/separate-thread sexp)
+    (send-sexp-to-mred sexp))
+
   (define queue-sexp-to-mred
     (lambda (sexp)
       (send-sexp-to-mred
@@ -319,7 +329,7 @@
              (define n (if use-local? l:n r:n))
              (choose ns ...))))]))
 
-(choose send-sexp-to-mred
+(choose send-sexp-to-mred send-sexp-to-mred/separate-thread
         queue-sexp-to-mred
         eof-result?
         shutdown-listener shutdown-mred mred-running?

gui-test/framework/tests/text.rkt

@@ -355,6 +355,98 @@
        (send t insert (new snip%) (send t last-position))
        (send t all-string-snips?)))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  searching
+;;
+
+(define (search-test name setup-code expected-answer)
+  (test
+   name
+   (λ (x) (equal? x expected-answer))
+   (λ ()
+     (send-sexp-to-mred/separate-thread
+      `(let ()
+         (define answer (make-channel))
+         (queue-callback
+          (λ ()
+            (define t (new text:searching%))
+            ,setup-code
+            (let loop ()
+              (cond
+                [(send t search-updates-pending?)
+                 (queue-callback (λ () (loop)) #f)]
+                [else
+                 (define-values (before total) (send t get-search-hit-count))
+                 (channel-put answer (list before total))]))))
+         (channel-get answer))))))
+
+(search-test
+ 'search.1
+ `(begin (send t insert "abc")
+         (send t set-position 0 0)
+         (send t set-searching-state "b" #f #f))
+ (list 0 1))
+
+(search-test
+ 'search.2
+ `(begin (send t insert "abc")
+         (send t set-position 3 3)
+         (send t set-searching-state "b" #f #f))
+ (list 1 1))
+
+(search-test
+ 'search.3
+ `(begin (send t insert "abc")
+         (define t2 (new text%))
+         (send t2 insert "abc")
+         (send t insert (new editor-snip% [editor t2]))
+         (send t2 insert "abc")
+         (send t set-position 0 0)
+         (send t set-searching-state "b" #f #f))
+ (list 0 3))
+
+(search-test
+ 'search.4
+ `(begin (send t insert "abc")
+         (define t2 (new text%))
+         (send t2 insert "abc")
+         (send t insert (new editor-snip% [editor t2]))
+         (send t insert "abc")
+         (send t set-position (send t last-position) (send t last-position))
+         (send t set-searching-state "b" #f #f))
+ (list 3 3))
+
+(search-test
+ 'search.5
+ `(begin (send t insert "abc")
+         (define t2 (new text%))
+         (send t2 insert "abc")
+         (define t3 (new text%))
+         (send t3 insert "abc")
+         (send t2 insert (new editor-snip% [editor t3]))
+         (send t2 insert "abc")
+         (send t insert (new editor-snip% [editor t2]))
+         (send t insert "abc")
+         (send t set-position (send t last-position) (send t last-position))
+         (send t set-searching-state "b" #f #f))
+ (list 5 5))
+
+(search-test
+ 'search.6
+ `(begin (send t insert "abc")
+         (define t2 (new text%))
+         (send t2 insert "abc")
+         (define t3 (new text%))
+         (send t3 insert "abc")
+         (send t2 insert (new editor-snip% [editor t3]))
+         (send t2 insert "abc")
+         (send t insert (new editor-snip% [editor t2]))
+         (send t insert "abc")
+         (send t set-position 0 0)
+         (send t set-searching-state "b" #f #f))
+ (list 0 5))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;  print-to-dc