fixes the responsiveness optimization disabled in

c8bee5acf7

collects/drracket/check-syntax.rkt

@@ -11,6 +11,9 @@
       (or/c path-string? #f)
       (values (->* (syntax?) ((-> syntax? void?)) void?)
               (-> void?)))]
+ 
+ [current-max-to-send-at-once
+  (parameter/c (or/c +inf.0 (and/c exact-integer? (>=/c 2))))]
  [syncheck-annotations<%>
   interface?]
  [current-annotations 
@@ -25,7 +28,7 @@
  syncheck:add-background-color
  syncheck:add-require-open-menu
  syncheck:add-docs-menu
- syncheck:add-rename-menu
+ syncheck:add-id-set
  syncheck:add-arrow
  syncheck:add-tail-arrow
  syncheck:add-mouse-over-status

collects/drracket/private/syncheck/gui.rkt

@@ -38,6 +38,7 @@ If the namespace does not, they are colored the unbound color.
          framework
          net/url
          browser/external
+         data/union-find
          (for-syntax racket/base)
          (only-in ffi/unsafe register-finalizer)
          "../../syncheck-drracket-button.rkt"
@@ -219,11 +220,15 @@ If the namespace does not, they are colored the unbound color.
     
     (define-struct tooltip-info (text pos-left pos-right msg) #:transparent)
     
+    ;; set : (uf-set (list/c source position span))
+    ;; name-dup? : symbol? -> boolean?
+    (define-struct identifier-location-set (set name-dup?) #:transparent)
+        
     ;; color : string
     ;; text: text:basic<%>
     ;; start, fin: number
     ;; used to represent regions to highlight when passing the mouse over the syncheck window
-    (define-struct colored-region (color text start fin))
+    (define-struct colored-region (color text start fin) #:transparent)
     
     ;; id : symbol  --  the nominal-source-id from identifier-binding
     ;; filename : path
@@ -355,11 +360,30 @@ If the namespace does not, they are colored the unbound color.
             ;;   - tail-link
             ;;   - arrow
             ;;   - string
+            ;;   - colored-region
+            ;;   - identifier-location-set
             (define/private (get-arrow-record table text)
+              (unless (object? text)
+                (error 'get-arrow-record "expected a text as the second argument, got ~e" text))
               (hash-ref! table text (lambda () (make-interval-map))))
 
             (define arrow-records #f)
             
+            (define/public (dump-arrow-records)
+              (cond
+                [arrow-records
+                 (for ([(k v) (in-hash arrow-records)])
+                   (printf "\n\n~s:\n" k)
+                   (let loop ([it (interval-map-iterate-first v)])
+                     (when it
+                       (printf "~s =>\n" (interval-map-iterate-key v it))
+                       (for ([v (in-list (interval-map-iterate-value v it))])
+                         (printf "  ~s\n" v))
+                       (printf "\n")
+                       (loop (interval-map-iterate-next v it)))))]
+                [else
+                 (printf "arrow-records empty\n")]))
+            
             ;; cleanup-texts : (or/c #f (listof text))
             (define cleanup-texts #f)
             
@@ -612,17 +636,23 @@ If the namespace does not, they are colored the unbound color.
                     (λ (x y)
                       (visit-docs-url)))))))
             
-            (define/public (syncheck:add-rename-menu id-as-sym to-be-renamed/poss name-dup?)
+            (define/public (syncheck:add-id-set to-be-renamed/poss name-dup?)
-              (define (make-menu menu)
+              (add-identifier-to-range to-be-renamed/poss name-dup?))
-                (let ([name-to-offer (format "~a" id-as-sym)])
+
+            (define/private (make-rename-menu menu an-identifier-location-set)
+              (define example-lst (set-first (uf-find (identifier-location-set-set an-identifier-location-set))))
+              (define name-to-offer (send (list-ref example-lst 0) get-text
+                                          (list-ref example-lst 1)
+                                          (list-ref example-lst 2)))
               (new menu-item%
                    [parent menu]
                    [label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)]
                    [callback
                     (λ (x y)
                       (let ([frame-parent (find-menu-parent menu)])
-                            (rename-callback name-to-offer
+                        (rename-menu-callback frame-parent
-                                             frame-parent)))])))
+                                              name-to-offer
+                                              an-identifier-location-set)))]))
               
               ;; rename-callback : string 
               ;;                   (and/c syncheck-text<%> definitions-text<%>)
@@ -631,7 +661,8 @@ If the namespace does not, they are colored the unbound color.
               ;;                   (union #f (is-a?/c top-level-window<%>)) 
               ;;                -> void
               ;; callback for the rename popup menu item
-              (define (rename-callback name-to-offer parent)
+            (define/private (rename-menu-callback parent name-to-offer an-identifier-location-set)
+              (define name-dup? (identifier-location-set-name-dup? an-identifier-location-set))
               (let ([new-str
                      (fw:keymap:call/text-keymap-initializer
                       (λ ()
@@ -661,11 +692,12 @@ If the namespace does not, they are colored the unbound color.
                          1)))
                   
                   (when do-renaming?
-                      (unless (null? to-be-renamed/poss)
                     (let ([txts (list this)])
                       (define positions-to-rename 
                         (remove-duplicates
-                             (sort to-be-renamed/poss
+                         (sort (set->list (uf-find
+                                           (identifier-location-set-set 
+                                            an-identifier-location-set)))
                                >
                                #:key cadr)))
                       (begin-edit-sequence)
@@ -681,11 +713,11 @@ If the namespace does not, they are colored the unbound color.
                           (send source-editor insert new-sym start start #f)))
                       (invalidate-bitmap-cache)
                       (for ([txt (in-list txts)])
-                            (send txt end-edit-sequence))))))))
+                        (send txt end-edit-sequence)))))))
               
               
               ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>)
-              (define (find-menu-parent menu)
+              (define/private (find-menu-parent menu)
                 (let loop ([menu menu])
                   (cond
                     [(is-a? menu menu-bar%) (send menu get-frame)]
@@ -702,12 +734,6 @@ If the namespace does not, they are colored the unbound color.
                     [(is-a? menu menu-item<%>) (loop (send menu get-parent))]
                     [else #f])))
             
-              (for ([loc (in-list to-be-renamed/poss)])
-                (define source (list-ref loc 0))
-                (define start (list-ref loc 1))
-                (define fin (list-ref loc 2))
-                (syncheck:add-menu source start fin id-as-sym make-menu)))
-              
             (define/private (syncheck:add-menu text start-pos end-pos key make-menu)
               (when arrow-records
                 (when (<= 0 start-pos end-pos (last-position))
@@ -792,6 +818,31 @@ If the namespace does not, they are colored the unbound color.
                                             start (add1 end) 
                                             to-add null)])))
             
+            (define/private (add-identifier-to-range text/start/ends name-dup?)
+              (define id-set (apply set text/start/ends))
+              (define fresh-uf (uf-new id-set))
+              (define new-il-set (identifier-location-set fresh-uf name-dup?))
+              (for ([text/start/span (in-list text/start/ends)])
+                (define arrow-record (get-arrow-record arrow-records (list-ref text/start/span 0)))
+                (define start (list-ref text/start/span 1))
+                (define end (list-ref text/start/span 2))
+                (interval-map-update*! arrow-record
+                                       start (add1 end)
+                                       (lambda (curr-val)
+                                         (define this-uf-set
+                                           (for/or ([thing (in-list curr-val)])
+                                             (and (identifier-location-set? thing)
+                                                  (identifier-location-set-set thing))))
+                                         (cond
+                                           [this-uf-set
+                                            (set! id-set (set-union (uf-find this-uf-set) id-set))
+                                            (uf-union! fresh-uf this-uf-set)
+                                            (uf-set-canonical! this-uf-set id-set)
+                                            curr-val]
+                                           [else 
+                                            (cons new-il-set curr-val)]))
+                                       '())))
+            
             (inherit get-top-level-window)
             
             (define/augment (on-change)
@@ -1092,6 +1143,10 @@ If the namespace does not, they are colored the unbound color.
                   (define var-arrows (filter var-arrow? arrows))
                   (define add-menus (append (map cdr (filter pair? vec-ents))
                                             (filter procedure? vec-ents)))
+                  (define identifier-location-set/f 
+                    (for/or ([x (in-list vec-ents)])
+                      (and (identifier-location-set? x)
+                           x)))
                   (unless (null? arrows)
                     (add-sep)
                     (make-object menu-item%
@@ -1149,7 +1204,10 @@ If the namespace does not, they are colored the unbound color.
                          arrow-record
                          start-selection
                          end-selection))))
-                  (for-each (λ (f) (f menu)) add-menus))))
+                  (for-each (λ (f) (f menu)) add-menus)
+                  (when identifier-location-set/f
+                    (make-rename-menu menu identifier-location-set/f))
+                  (void))))
             
             (define tooltip-frame #f)
             (define/private (update-tooltip-frame)
@@ -1635,7 +1693,7 @@ If the namespace does not, they are colored the unbound color.
              (send defs-text syncheck:add-require-open-menu defs-text start-pos end-pos file)]
             [`#(syncheck:add-docs-menu,start-pos ,end-pos ,key ,the-label ,path ,definition-tag ,tag)
              (send defs-text syncheck:add-docs-menu defs-text start-pos end-pos key the-label path definition-tag tag)]
-            [`#(syncheck:add-rename-menu ,id-as-sym ,to-be-renamed/poss ,name-dup-pc ,name-dup-id)
+            [`#(syncheck:add-id-set ,to-be-renamed/poss ,name-dup-pc ,name-dup-id)
              (define other-side-dead? #f)
              (define (name-dup? name) 
                (cond
@@ -1654,8 +1712,7 @@ If the namespace does not, they are colored the unbound color.
              (define to-be-renamed/poss/fixed
                (for/list ([lst (in-list to-be-renamed/poss)])
                  (list defs-text (list-ref lst 0) (list-ref lst 1))))
-             (send defs-text syncheck:add-rename-menu id-as-sym to-be-renamed/poss/fixed 
+             (send defs-text syncheck:add-id-set to-be-renamed/poss/fixed name-dup?)]))
-                   name-dup?)]))
         
         (define/augment (enable-evaluation)
           (send check-syntax-button enable #t)

collects/drracket/private/syncheck/intf.rkt

@@ -8,7 +8,7 @@
     syncheck:add-background-color
     syncheck:add-require-open-menu
     syncheck:add-docs-menu
-    syncheck:add-rename-menu
+    syncheck:add-id-set
     syncheck:add-arrow
     syncheck:add-tail-arrow
     syncheck:add-mouse-over-status
@@ -36,7 +36,7 @@
     (define/public (syncheck:find-source-object stx) #f)
     (define/public (syncheck:add-background-color source start end color) (void))
     (define/public (syncheck:add-require-open-menu source start end key) (void))
-    (define/public (syncheck:add-rename-menu id all-ids new-name-intereferes?) (void))
+    (define/public (syncheck:add-id-set id all-ids new-name-intereferes?) (void))
     (define/public (syncheck:add-docs-menu text start-pos end-pos key the-label path definition-tag tag) (void))
     (define/public (syncheck:add-arrow start-text start-pos-left start-pos-right
                                        end-text end-pos-left end-pos-right

collects/drracket/private/syncheck/local-member-names.rkt

@@ -13,7 +13,7 @@
   syncheck:add-docs-menu
   syncheck:color-range
   syncheck:add-require-open-menu
-  syncheck:add-rename-menu
+  syncheck:add-id-set
   syncheck:add-arrow
   syncheck:add-tail-arrow
   syncheck:add-mouse-over-status

collects/drracket/private/syncheck/online-comp.rkt

@@ -56,10 +56,10 @@
     (log syncheck:add-jump-to-definition _text start end id filename)
     (log syncheck:add-require-open-menu _text start-pos end-pos file)
     (log syncheck:add-docs-menu _text start-pos end-pos key the-label path definition-tag tag)
-    (define/override (syncheck:add-rename-menu id-as-sym to-be-renamed/poss dup-name?)
+    (define/override (syncheck:add-id-set to-be-renamed/poss dup-name?)
       (define id (hash-count table))
       (hash-set! table id dup-name?)
-      (add-to-trace (vector 'syncheck:add-rename-menu id-as-sym (map cdr to-be-renamed/poss) remote id)))
+      (add-to-trace (vector 'syncheck:add-id-set (map cdr to-be-renamed/poss) remote id)))
     
     (define/public (get-trace) (reverse trace))
     (define/private (add-to-trace thing) 
@@ -67,6 +67,7 @@
     (super-new)))
 
 (define (go expanded path the-source orig-cust)
+  (parameterize ([current-max-to-send-at-once 50])
     (with-handlers ((exn:fail? (λ (x) 
                                  (printf "~a\n" (exn-message x))
                                  (printf "---\n")
@@ -86,4 +87,4 @@
       (parameterize ([current-annotations obj])
         (expanded-expression expanded)
         (expansion-completed))
-    (send obj get-trace)))
+      (send obj get-trace))))

collects/drracket/private/syncheck/traversals.rkt

@@ -12,11 +12,15 @@
          racket/set
          racket/class
          racket/list
+         racket/contract
          syntax/boundmap
          framework/preferences
          scribble/manual-struct)
 
-(provide make-traversal)
+(provide make-traversal
+         current-max-to-send-at-once)
+
+(define current-max-to-send-at-once (make-parameter +inf.0))
     
     
     ;                                                                                                             
@@ -1134,10 +1138,23 @@
                                   (for/or ([(level id-set) (in-hash phase-to-map)])
                                     (get-ids id-set new-id))))))))
                       #t))
-               (send defs-text syncheck:add-rename-menu
+               
-                     id-as-sym
+               (define max-to-send-at-once (current-max-to-send-at-once))
+               (let loop ([loc-lst loc-lst]
+                          [len (length loc-lst)])
+                 (cond
+                   [(<= len max-to-send-at-once)
+                    (send defs-text syncheck:add-id-set
                           loc-lst
-                     name-dup?)))))))
+                          name-dup?)]
+                   [else
+                    (send defs-text syncheck:add-id-set
+                          (take loc-lst max-to-send-at-once)
+                          name-dup?)
+                    ;; drop one fewer so that we're sure that the 
+                    ;; sets get unioned properly
+                    (loop (drop loc-lst (- max-to-send-at-once 1))
+                          (- len (- max-to-send-at-once 1)))]))))))))
     
     ;; remove-duplicates-stx : (listof syntax[original]) -> (listof syntax[original])
     ;; removes duplicates, based on the source locations of the identifiers

collects/scribblings/tools/tools.scrbl

@@ -650,6 +650,10 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
   from @racket[make-traversal]. 
 }
 
+@defparam[current-max-to-send-at-once m (or/c +inf.0 (and/c exact-integer? (>=/c 2)))]{
+ See @xmethod[syncheck-annotations<%> syncheck:add-id-set].
+}
+
 @definterface[syncheck-annotations<%> ()]{
 
   Classes implementing this interface are
@@ -708,14 +712,26 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
    be longer than 200 characters).
  }
                   
- @defmethod[(syncheck:add-rename-menu [id symbol?]
+ @defmethod[(syncheck:add-id-set [all-ids (listof (list/c (not/c #f) 
-                                      [all-ids (listof (list/c (not/c #f) exact-nonnegative-integer? exact-nonnegative-integer?))]
+                                                          exact-nonnegative-integer?
+                                                          exact-nonnegative-integer?))]
                                  [new-name-interferes? (-> symbol boolean?)])
             void?]{
-   Called to indicate that there is a variable that can be renamed. The
+   Called to indicate that all of the locations in the @racket[all-ids] list 
-   identifier's name is @racket[id] and all of the occurrences of the identifier are given in the
+   refer to the same identifier.
-   list @racket[all-ids]. The @racket[new-name-interferes?] procedure determines if a potential name would 
+   
-   interfere with the existing bindings.
+   The @racket[new-name-interferes?] procedure determines if a potential new name
+   at one of the corresponding places would interfere with the existing bindings
+   in the program.
+   
+   Usually, this method is called with maximal sets in @racket[all-ids], in the
+   sense that, for a given call, either a source location is in the list, or
+   the location it does not contain a identifier that refers to one of the ones
+   in @racket[all-ids]. If, however, @racket[current-max-to-send-at-once] is not
+   @racket[+inf.0], then this set might not contain all of the source locations
+   for a given identifier and multiple calls are made. In the case that multiple
+   calls are made, the intersection of the @racket[all-ids] lists (on those
+   multiple calls) is non-empty.
  }
                   
  @defmethod[(syncheck:add-arrow [start-source-obj (not/c #f)]