refactored to make testing check syntax renaming possible

made sure to remove duplicates from the list before doing renaming
  closes PR 11659

collects/drracket/private/syncheck/gui.rkt

@@ -69,6 +69,7 @@ If the namespace does not, they are colored the unbound color.
                          (λ (x) (memq x '(default-mode 
                                            my-obligations-mode 
                                            client-obligations-mode))))
+
 (define tool@ 
   (unit 
     (import drracket:tool^)
@@ -691,91 +692,100 @@ If the namespace does not, they are colored the unbound color.
                             (invalidate-bitmap-cache))]))
                      (super on-event event)]
                     [(send event button-down? 'right)
-                     (let-values ([(pos text) (get-pos/text event)])
+                     (define menu
-                       (if (and pos (is-a? text text%))
+                       (let-values ([(pos text) (get-pos/text event)])
-                           (let ([arrow-record (hash-ref arrow-records text #f)])
+                         (syncheck:build-popup-menu pos text)))
-                             (when arrow-record
+                     (cond
-                               (let ([vec-ents (interval-map-ref arrow-record pos null)]
+                       [menu
-                                     [start-selection (send text get-start-position)]
+                        (send (get-canvas) popup-menu menu
-                                     [end-selection (send text get-end-position)])
+                              (+ 1 (inexact->exact (floor (send event get-x))))
-                                 (cond
+                              (+ 1 (inexact->exact (floor (send event get-y)))))]
-                                   [(and (null? vec-ents) (= start-selection end-selection))
+                       [else
-                                    (super on-event event)]
+                        (super on-event event)])]
-                                   [else
-                                    (let* ([menu (make-object popup-menu% #f)]
-                                           [arrows (filter arrow? vec-ents)]
-                                           [def-links (filter def-link? vec-ents)]
-                                           [var-arrows (filter var-arrow? arrows)]
-                                           [add-menus (map cdr (filter pair? vec-ents))])
-                                      (unless (null? arrows)
-                                        (make-object menu-item%
-                                          (string-constant cs-tack/untack-arrow)
-                                          menu
-                                          (λ (item evt) (tack/untack-callback arrows))))
-                                      (unless (null? def-links)
-                                        (let ([def-link (car def-links)])
-                                          (make-object menu-item%
-                                            jump-to-definition
-                                            menu
-                                            (λ (item evt)
-                                              (jump-to-definition-callback def-link)))))
-                                      (unless (null? var-arrows)
-                                        (make-object menu-item%
-                                          jump-to-next-bound-occurrence
-                                          menu
-                                          (λ (item evt) (jump-to-next-callback pos text arrows)))
-                                        (make-object menu-item%
-                                          jump-to-binding
-                                          menu
-                                          (λ (item evt) (jump-to-binding-callback arrows))))
-                                      (unless (= start-selection end-selection)
-                                        (let ([arrows-menu
-                                               (make-object menu%
-                                                            "Arrows crossing selection"
-                                                            menu)]
-                                              [callback
-                                               (lambda (accept)
-                                                 (tack-crossing-arrows-callback
-                                                  arrow-record
-                                                  start-selection
-                                                  end-selection
-                                                  text
-                                                  accept))])
-                                          (make-object menu-item%
-                                                       "Tack arrows"
-                                                       arrows-menu
-                                                       (lambda (item evt)
-                                                         (callback
-                                                          '(lexical top-level imported))))
-                                          (make-object menu-item%
-                                                       "Tack non-import arrows"
-                                                       arrows-menu
-                                                       (lambda (item evt)
-                                                         (callback
-                                                          '(lexical top-level))))
-                                          (make-object menu-item%
-                                                       "Untack arrows"
-                                                       arrows-menu
-                                                       (lambda (item evt)
-                                                         (untack-crossing-arrows
-                                                          arrow-record
-                                                          start-selection
-                                                          end-selection)))))
-                                      (for-each (λ (f) (f menu)) add-menus)
-                                      
-                                      (drracket:unit:add-search-help-desk-menu-item
-                                       text
-                                       menu
-                                       event
-                                       (λ () (new separator-menu-item% [parent menu])))
-                                      
-                                      (send (get-canvas) popup-menu menu
-                                            (+ 1 (inexact->exact (floor (send event get-x))))
-                                            (+ 1 (inexact->exact (floor (send event get-y))))))]))))
-                           (super on-event event)))]
                     [else (super on-event event)])
                   (super on-event event)))
 
+            (define/public (syncheck:build-popup-menu pos text)
+              (and pos
+                   (is-a? text text%)
+                   (let ([arrow-record (hash-ref arrow-records text #f)])
+                     (and arrow-record
+                          (let ([vec-ents (interval-map-ref arrow-record pos null)]
+                                [start-selection (send text get-start-position)]
+                                [end-selection (send text get-end-position)])
+                            (cond
+                              [(and (null? vec-ents) (= start-selection end-selection))
+                               #f]
+                              [else
+                               (let* ([menu (make-object popup-menu% #f)]
+                                      [arrows (filter arrow? vec-ents)]
+                                      [def-links (filter def-link? vec-ents)]
+                                      [var-arrows (filter var-arrow? arrows)]
+                                      [add-menus (map cdr (filter pair? vec-ents))])
+                                 (unless (null? arrows)
+                                   (make-object menu-item%
+                                     (string-constant cs-tack/untack-arrow)
+                                     menu
+                                     (λ (item evt) (tack/untack-callback arrows))))
+                                 (unless (null? def-links)
+                                   (let ([def-link (car def-links)])
+                                     (make-object menu-item%
+                                       jump-to-definition
+                                       menu
+                                       (λ (item evt)
+                                         (jump-to-definition-callback def-link)))))
+                                 (unless (null? var-arrows)
+                                   (make-object menu-item%
+                                     jump-to-next-bound-occurrence
+                                     menu
+                                     (λ (item evt) (jump-to-next-callback pos text arrows)))
+                                   (make-object menu-item%
+                                     jump-to-binding
+                                     menu
+                                     (λ (item evt) (jump-to-binding-callback arrows))))
+                                 (unless (= start-selection end-selection)
+                                   (let ([arrows-menu
+                                          (make-object menu%
+                                            "Arrows crossing selection"
+                                            menu)]
+                                         [callback
+                                          (lambda (accept)
+                                            (tack-crossing-arrows-callback
+                                             arrow-record
+                                             start-selection
+                                             end-selection
+                                             text
+                                             accept))])
+                                     (make-object menu-item%
+                                       "Tack arrows"
+                                       arrows-menu
+                                       (lambda (item evt)
+                                         (callback
+                                          '(lexical top-level imported))))
+                                     (make-object menu-item%
+                                       "Tack non-import arrows"
+                                       arrows-menu
+                                       (lambda (item evt)
+                                         (callback
+                                          '(lexical top-level))))
+                                     (make-object menu-item%
+                                       "Untack arrows"
+                                       arrows-menu
+                                       (lambda (item evt)
+                                         (untack-crossing-arrows
+                                          arrow-record
+                                          start-selection
+                                          end-selection)))))
+                                 (for-each (λ (f) (f menu)) add-menus)
+                                 
+                                 (drracket:unit:add-search-help-desk-menu-item
+                                  text
+                                  menu
+                                  pos
+                                  (λ () (new separator-menu-item% [parent menu])))
+                               
+                                 menu)]))))))
+            
             (define/private (update-status-line eles)
               (let ([has-txt? #f])
                 (for-each (λ (ele)

collects/drracket/private/syncheck/traversals.rkt

@@ -1395,7 +1395,7 @@
                     (loop (list (syntax-source stx)
                                 (syntax-position stx)
                                 (syntax-span stx))))))))
-          (define to-be-renamed (sort (hash-map all-stxs (λ (k v) k)) > #:key syntax-position))
+          (define to-be-renamed (hash-map all-stxs (λ (k v) k)))
           (define do-renaming?
             (or (not (name-duplication? to-be-renamed id-sets new-sym))
                 (equal?
@@ -1412,22 +1412,30 @@
           (when do-renaming?
             (unless (null? to-be-renamed)
               (let ([txts (list defs-text)])
+                (define positions-to-rename 
+                  (remove-duplicates
+                   (sort (map (λ (stx) (list (find-source-editor/defs stx defs-text)
+                                             (syntax-position stx)
+                                             (syntax-span stx)))
+                              to-be-renamed)
+                         >
+                         #:key cadr)))
                 (send defs-text begin-edit-sequence)
-                (for-each (λ (stx) 
+                (for ([info (in-list positions-to-rename)])
-                            (let ([source-editor (find-source-editor/defs stx defs-text)])
+                  (define source-editor (list-ref info 0))
-                              (when (is-a? source-editor text%)
+                  (define position (list-ref info 1))
-                                (unless (memq source-editor txts)
+                  (define span (list-ref info 2))
-                                  (send source-editor begin-edit-sequence)
+                  (when (is-a? source-editor text%)
-                                  (set! txts (cons source-editor txts)))
+                    (unless (memq source-editor txts)
-                                (let* ([start (- (syntax-position stx) 1)]
+                      (send source-editor begin-edit-sequence)
-                                       [end (+ start (syntax-span stx))])
+                      (set! txts (cons source-editor txts)))
-                                  (send source-editor delete start end #f)
+                    (let* ([start (- position 1)]
-                                  (send source-editor insert new-sym start start #f)))))
+                           [end (+ start span)])
-                          to-be-renamed)
+                      (send source-editor delete start end #f)
+                      (send source-editor insert new-sym start start #f))))
                 (send defs-text invalidate-bitmap-cache)
-                (for-each
+                (for ([txt (in-list txts)])
-                 (λ (txt) (send txt end-edit-sequence))
+                  (send txt end-edit-sequence))))))))
-                 txts)))))))
     
     ;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean
     ;; returns #t if the name chosen would be the same as another name in this scope.

collects/drracket/private/unit.rkt

@@ -144,7 +144,13 @@ module browser threading seems wrong.
                         (set! added? #t)
                         (new separator-menu-item% [parent menu]))))])
              
-             (add-search-help-desk-menu-item text menu event add-sep)
+             (add-search-help-desk-menu-item text menu
+                                             (let-values ([(x y)
+                                                           (send text dc-location-to-editor-location
+                                                                 (send event get-x)
+                                                                 (send event get-y))])
+                                               (send text find-position x y))
+                                             add-sep)
              
              (when (is-a? text editor:basic<%>)
                (let-values ([(pos text) (send text get-pos/text event)])
@@ -181,20 +187,12 @@ module browser threading seems wrong.
              
              (void))))))
     
-    (define (add-search-help-desk-menu-item text menu event [add-sep void])
+    (define (add-search-help-desk-menu-item text menu position [add-sep void])
       (let* ([end (send text get-end-position)]
              [start (send text get-start-position)])
         (unless (= 0 (send text last-position))
           (let* ([str (if (= end start)
-                          (find-symbol
+                          (find-symbol text position)
-                           text
-                           (call-with-values
-                            (λ ()
-                              (send text dc-location-to-editor-location
-                                    (send event get-x)
-                                    (send event get-y)))
-                            (λ (x y)
-                              (send text find-position x y))))
                           (send text get-text start end))]
                  ;; almost the same code as "search-help-desk" in "rep.rkt"
                  [l (send text get-canvas)]

collects/drracket/tool-lib.rkt

@@ -627,19 +627,18 @@ all of the names in the tools library, for use defining keybindings
  
  (proc-doc/names
   drracket:unit:add-search-help-desk-menu-item
-  (->* ((is-a?/c text%) (is-a?/c menu-item-container<%>) (is-a?/c mouse-event%)) ((-> any)) void?)
+  (->* ((is-a?/c text%) (is-a?/c menu-item-container<%>) exact-nonnegative-integer?) ((-> any)) void?)
-  ((text menu event)
+  ((text menu position)
    ((add-sep void)))
-  @{Assuming that @racket[event] represents a mouse click in @racket[text], this
+  @{Adds a menu item to @racket[menu] that searches in Help Desk
-                  adds a menu item to @racket[menu] that searches in Help Desk
+  for the word around @racket[position] in @racket[text].
-                  for the text around the point where the click happened.
   
-                  If there is only whitespace around the insertion point,
+  If there is only whitespace around @racket[position],
-                  then no @racket[menu-item%]s are added, and
+  then no @racket[menu-item%]s are added, and
-                  @racket[add-sep] is not called. If there is something to be
+  @racket[add-sep] is not called. If there is something to be
-                  added, then @racket[add-sep] is called before the menu item is
+  added, then @racket[add-sep] is called before the menu item is
-                  created.
+  created.
-                  })
+  })
   
  
  ;                                            

collects/tests/drracket/syncheck-test.rkt

@@ -1,3 +1,4 @@
+#lang racket/base
 
 #|
 
@@ -5,15 +6,14 @@ tests involving object% are commented out, since they
 trigger runtime errors in check syntax.
 
 |#
-#lang scheme/base
 
   (require "drracket-test-util.rkt"
            string-constants/string-constant
            tests/utils/gui
-           scheme/path
+           racket/path
-           scheme/class
+           racket/class
-           scheme/list
+           racket/list
-           scheme/file
+           racket/file
            mred
            framework
            mrlib/text-string-style-desc)
@@ -24,8 +24,10 @@ trigger runtime errors in check syntax.
   ;; type test = (make-test string
   ;;                        (listof str/ann)
   ;;                        (listof (cons (list number number) (listof (list number number)))))
-  (define-struct test (input expected arrows))
+  (define-struct test (input expected arrows) #:transparent)
-  (define-struct (dir-test test) ())
+  (define-struct (dir-test test) () #:transparent)
+  
+  (define-struct rename-test (input pos old-name new-name output) #:transparent)
   
   (define build-test
     (λ (input expected [arrow-table '()])
@@ -34,7 +36,6 @@ trigger runtime errors in check syntax.
   ;; tests : (listof test)
   (define tests
     (list 
-     
      (build-test "12345"
                 '(("12345" constant)))
      (build-test "'abcdef"
@@ -877,7 +878,103 @@ trigger runtime errors in check syntax.
                    (") "            default-color)
                    ("#'"            imported)
                    ("1))"           default-color))
-                 (list '((27 33) (19 26) (36 49) (53 59) (64 66))))))
+                 (list '((27 33) (19 26) (36 49) (53 59) (64 66))))
+     
+     (rename-test "(lambda (x) x)"
+                  9
+                  "x"
+                  "y"
+                  "(lambda (y) y)")
+     
+     (rename-test "(lambda (x) x)"
+                  9
+                  "x"
+                  "yy"
+                  "(lambda (yy) yy)")
+     
+     (rename-test "(lambda (x) x)"
+                  9
+                  "x"
+                  "yxy"
+                  "(lambda (yxy) yxy)")
+     (rename-test "(lambda (x) x x)"
+                  9
+                  "x"
+                  "yxy"
+                  "(lambda (yxy) yxy yxy)")
+     (rename-test "(lambda (x) x x)"
+                  12
+                  "x"
+                  "yxy"
+                  "(lambda (yxy) yxy yxy)")
+     (rename-test "(lambda (x) x x)"
+                  14
+                  "x"
+                  "yxy"
+                  "(lambda (yxy) yxy yxy)")
+     
+     (rename-test "(define-syntax-rule (m x) (λ (x) x))(m z)"
+                  39
+                  "z"
+                  "qq"
+                  "(define-syntax-rule (m x) (λ (x) x))(m qq)")
+     
+     (rename-test (string-append
+                   "#lang racket"
+                   "\n"
+                   "(define player%\n"
+                   " (class object%\n"
+                   "   (init-field strategy player# tiles)\n"
+                   "   (field [score (set)])\n"
+                   "\n"
+                   "   (super-new)\n"
+                   "\n"
+                   "   (define/private (put t pl)\n"
+                   "     (set! tiles(remove t tiles)))))\n")
+                  80
+                  "tiles"
+                  "*tiles"
+                  (string-append
+                   "#lang racket"
+                   "\n"
+                   "(define player%\n"
+                   " (class object%\n"
+                   "   (init-field strategy player# *tiles)\n"
+                   "   (field [score (set)])\n"
+                   "\n"
+                   "   (super-new)\n"
+                   "\n"
+                   "   (define/private (put t pl)\n"
+                   "     (set! *tiles(remove t *tiles)))))\n"))
+     
+     (rename-test (string-append
+                   "#lang racket"
+                   "\n"
+                   "(define player%\n"
+                   " (class object%\n"
+                   "   (init-field strategy player# *tiles)\n"
+                   "   (field [score (set)])\n"
+                   "\n"
+                   "   (super-new)\n"
+                   "\n"
+                   "   (define/private (put t pl)\n"
+                   "     (set! *tiles(remove t *tiles)))))\n")
+                  80
+                  "*tiles"
+                  "tiles"
+                  (string-append
+                   "#lang racket"
+                   "\n"
+                   "(define player%\n"
+                   " (class object%\n"
+                   "   (init-field strategy player# tiles)\n"
+                   "   (field [score (set)])\n"
+                   "\n"
+                   "   (super-new)\n"
+                   "\n"
+                   "   (define/private (put t pl)\n"
+                   "     (set! tiles(remove t tiles)))))\n"))))
+                  
   
   (define (main)
     (fire-up-drscheme-and-run-tests
@@ -917,45 +1014,76 @@ trigger runtime errors in check syntax.
   (define ((run-one-test save-dir) test)
     (set! total-tests-run (+ total-tests-run 1))
     (let* ([drs (wait-for-drscheme-frame)]
-           [defs (queue-callback/res (λ () (send drs get-definitions-text)))]
+           [defs (queue-callback/res (λ () (send drs get-definitions-text)))])
-           [input (test-input test)]
-           [expected (test-expected test)]
-           [arrows (test-arrows test)]
-           [relative (find-relative-path save-dir (collection-path "mzlib"))])
       (clear-definitions drs)
       (cond
-        [(dir-test? test)
+        [(test? test)
-         (insert-in-definitions drs (format input (path->string relative)))]
+         (let ([input (test-input test)]
-        [else (insert-in-definitions drs input)])
+               [expected (test-expected test)]
-      (click-check-syntax-button drs)
+               [arrows (test-arrows test)]
-      (wait-for-computation drs)
+               [relative (find-relative-path save-dir (collection-path "mzlib"))])
+           (cond
+             [(dir-test? test)
+              (insert-in-definitions drs (format input (path->string relative)))]
+             [else (insert-in-definitions drs input)])
+           (click-check-syntax-and-check-errors drs test)
            
-      (when (queue-callback/res (λ () (send defs in-edit-sequence?)))
+           ;; need to check for syntax error here
-        (error 'syncheck-test.rkt "still in edit sequence for ~s" input))
+           (let ([got (get-annotated-output drs)])
-      
+             (compare-output (cond
-      (let ([err (queue-callback/res (λ () (send drs syncheck:get-error-report-contents)))]) 
+                               [(dir-test? test)
-        (when err
+                                (map (lambda (x)
-          (fprintf (current-error-port)
+                                       (list (if (eq? (car x) 'relative-path)
-                   "FAILED ~s\n   error report window is visible:\n   ~a\n"
+                                               (path->string relative)
-                   input
+                                               (car x))
-                   err)))
+                                             (cadr x)))
-      
+                                     expected)]
-      ;; need to check for syntax error here
+                               [else
-      (let ([got (get-annotated-output drs)])
+                                expected])
-        (compare-output (cond
+                             got
-                          [(dir-test? test)
+                             arrows 
-                           (map (lambda (x)
+                             (queue-callback/res (λ () (send defs syncheck:get-bindings-table)))
-                                  (list (if (eq? (car x) 'relative-path)
+                             input)))]
-                                            (path->string relative)
+        [(rename-test? test)
-                                            (car x))
+         (insert-in-definitions drs (rename-test-input test))
-                                        (cadr x)))
+         (click-check-syntax-and-check-errors drs test)
-                                expected)]
+         (define menu-item
-                          [else
+           (queue-callback/res
-                           expected])
+            (λ ()
-                        got
+              (define defs (send drs get-definitions-text))
-                        arrows 
+              (define menu (send defs syncheck:build-popup-menu (rename-test-pos test) defs))
-                        (queue-callback/res (λ () (send defs syncheck:get-bindings-table)))
+              (define item-name (format "Rename ~a" (rename-test-old-name test)))
-                        input))))
+              (define menu-item
+                (for/or ([x (in-list (send menu get-items))])
+                  (and (is-a? x labelled-menu-item<%>)
+                       (equal? (send x get-label) item-name)
+                       x)))
+              (cond
+                [menu-item
+                 menu-item]
+                [else
+                 (fprintf (current-error-port)
+                          "syncheck-test.rkt: rename test ~s didn't find menu item named ~s in ~s"
+                          test
+                          item-name
+                          (map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
+                               (send menu get-items)))
+                 #f]))))
+         (when menu-item
+           (queue-callback (λ () (send menu-item command (make-object control-event% 'menu))))
+           (wait-for-new-frame drs)
+           (for ([x (in-string (rename-test-new-name test))])
+             (test:keystroke x))
+           (test:button-push "OK")
+           (define result
+             (queue-callback/res (λ () 
+                                   (define defs (send drs get-definitions-text))
+                                   (send defs get-text 0 (send defs last-position)))))
+           (unless (equal? result (rename-test-output test))
+             (fprintf (current-error-port)
+                      "syncheck-test.rkt FAILED\n   test ~s\n  got ~s\n" 
+                      test
+                      result)))])))
   
   
   (define remappings
@@ -1044,6 +1172,19 @@ trigger runtime errors in check syntax.
   (define (get-annotated-output drs)
     (queue-callback/res (λ () (get-string/style-desc (send drs get-definitions-text)))))
   
+  (define (click-check-syntax-and-check-errors drs test)
+    (click-check-syntax-button drs)
+    (wait-for-computation drs)
+    (when (queue-callback/res (λ () (send (send drs get-definitions-text) in-edit-sequence?)))
+      (error 'syncheck-test.rkt "still in edit sequence for ~s" test))
+    
+    (let ([err (queue-callback/res (λ () (send drs syncheck:get-error-report-contents)))]) 
+      (when err
+        (fprintf (current-error-port)
+                 "FAILED ~s\n   error report window is visible:\n   ~a\n"
+                 test
+                 err))))
+  
   (define (click-check-syntax-button drs)
     (test:run-one (lambda () (send (send drs syncheck:get-button) command))))