diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index bd057fae31..79afcd6540 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/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,90 +692,99 @@ 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)]) - (if (and pos (is-a? text text%)) - (let ([arrow-record (hash-ref arrow-records text #f)]) - (when 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)) - (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)))] + (define menu + (let-values ([(pos text) (get-pos/text event)]) + (syncheck:build-popup-menu pos text))) + (cond + [menu + (send (get-canvas) popup-menu menu + (+ 1 (inexact->exact (floor (send event get-x)))) + (+ 1 (inexact->exact (floor (send event get-y)))))] + [else + (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]) diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt index 8affcf5c72..88c2e08225 100644 --- a/collects/drracket/private/syncheck/traversals.rkt +++ b/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) - (let ([source-editor (find-source-editor/defs stx defs-text)]) - (when (is-a? source-editor text%) - (unless (memq source-editor txts) - (send source-editor begin-edit-sequence) - (set! txts (cons source-editor txts))) - (let* ([start (- (syntax-position stx) 1)] - [end (+ start (syntax-span stx))]) - (send source-editor delete start end #f) - (send source-editor insert new-sym start start #f))))) - to-be-renamed) + (for ([info (in-list positions-to-rename)]) + (define source-editor (list-ref info 0)) + (define position (list-ref info 1)) + (define span (list-ref info 2)) + (when (is-a? source-editor text%) + (unless (memq source-editor txts) + (send source-editor begin-edit-sequence) + (set! txts (cons source-editor txts))) + (let* ([start (- position 1)] + [end (+ start span)]) + (send source-editor delete start end #f) + (send source-editor insert new-sym start start #f)))) (send defs-text invalidate-bitmap-cache) - (for-each - (λ (txt) (send txt end-edit-sequence)) - txts))))))) + (for ([txt (in-list txts)]) + (send txt end-edit-sequence)))))))) ;; 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. diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 9354c1144d..10a3f226ca 100644 --- a/collects/drracket/private/unit.rkt +++ b/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 - 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)))) + (find-symbol text position) (send text get-text start end))] ;; almost the same code as "search-help-desk" in "rep.rkt" [l (send text get-canvas)] diff --git a/collects/drracket/tool-lib.rkt b/collects/drracket/tool-lib.rkt index 4812f2d21e..b733d675dd 100644 --- a/collects/drracket/tool-lib.rkt +++ b/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?) - ((text menu event) + (->* ((is-a?/c text%) (is-a?/c menu-item-container<%>) exact-nonnegative-integer?) ((-> any)) void?) + ((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 - for the text around the point where the click happened. - - If there is only whitespace around the insertion point, - then no @racket[menu-item%]s are added, and - @racket[add-sep] is not called. If there is something to be - added, then @racket[add-sep] is called before the menu item is - created. - }) + @{Adds a menu item to @racket[menu] that searches in Help Desk + for the word around @racket[position] in @racket[text]. + + If there is only whitespace around @racket[position], + then no @racket[menu-item%]s are added, and + @racket[add-sep] is not called. If there is something to be + added, then @racket[add-sep] is called before the menu item is + created. + }) ; diff --git a/collects/tests/drracket/syncheck-test.rkt b/collects/tests/drracket/syncheck-test.rkt index addc5c930a..49f2436ee4 100644 --- a/collects/tests/drracket/syncheck-test.rkt +++ b/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 - scheme/class - scheme/list - scheme/file + racket/path + racket/class + racket/list + 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 (dir-test test) ()) + (define-struct test (input expected arrows) #:transparent) + (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)))] - [input (test-input test)] - [expected (test-expected test)] - [arrows (test-arrows test)] - [relative (find-relative-path save-dir (collection-path "mzlib"))]) + [defs (queue-callback/res (λ () (send drs get-definitions-text)))]) (clear-definitions drs) (cond - [(dir-test? test) - (insert-in-definitions drs (format input (path->string relative)))] - [else (insert-in-definitions drs input)]) - (click-check-syntax-button drs) - (wait-for-computation drs) - - (when (queue-callback/res (λ () (send defs in-edit-sequence?))) - (error 'syncheck-test.rkt "still in edit sequence for ~s" input)) - - (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" - input - err))) - - ;; need to check for syntax error here - (let ([got (get-annotated-output drs)]) - (compare-output (cond - [(dir-test? test) - (map (lambda (x) - (list (if (eq? (car x) 'relative-path) - (path->string relative) - (car x)) - (cadr x))) - expected)] - [else - expected]) - got - arrows - (queue-callback/res (λ () (send defs syncheck:get-bindings-table))) - input)))) + [(test? test) + (let ([input (test-input test)] + [expected (test-expected test)] + [arrows (test-arrows test)] + [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) + + ;; need to check for syntax error here + (let ([got (get-annotated-output drs)]) + (compare-output (cond + [(dir-test? test) + (map (lambda (x) + (list (if (eq? (car x) 'relative-path) + (path->string relative) + (car x)) + (cadr x))) + expected)] + [else + expected]) + got + arrows + (queue-callback/res (λ () (send defs syncheck:get-bindings-table))) + input)))] + [(rename-test? test) + (insert-in-definitions drs (rename-test-input test)) + (click-check-syntax-and-check-errors drs test) + (define menu-item + (queue-callback/res + (λ () + (define defs (send drs get-definitions-text)) + (define menu (send defs syncheck:build-popup-menu (rename-test-pos test) defs)) + (define item-name (format "Rename ~a" (rename-test-old-name test))) + (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))))