Skip to content

Fix renaming in DrRacket #415

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 3 commits into from
Sep 8, 2020
Merged

Fix renaming in DrRacket #415

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
dbc025d
Fix renaming in DrRacket
sorawee Sep 6, 2020
a9b5f70
Add tests
sorawee Sep 7, 2020
3102153
PR feedback
sorawee Sep 8, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
23 changes: 21 additions & 2 deletions drracket-test/tests/drracket/syncheck-test.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -31,7 +31,8 @@
(define-struct test (line input expected arrows tooltips setup teardown extra-files extra-info?)
#:transparent)
(define-struct (dir-test test) () #:transparent)


;; When either `new-name` or `output` is `#f`, only test that `old-name` is on the menu
(define-struct rename-test (line input pos old-name new-name output) #:transparent)
(define-struct prefix-test (line input pos prefix output) #:transparent)

Expand Down Expand Up @@ -1547,6 +1548,24 @@
" y`1\n"
" `2)\n"))

(build-rename-test
(string-append
"#lang racket\n"
"(require racket/list)\n")
14
"require"
#f
#f)

(build-rename-test
(string-append
"#lang racket\n"
"(require racket/list)\n")
20
"require"
#f
#f)

(build-test
#:extra-files
(hash "define-suffix.rkt"
Expand Down Expand Up @@ -1766,7 +1785,7 @@
(map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
(send menu get-items)))
#f]))))
(when menu-item
(when (and menu-item (rename-test-new-name test) (rename-test-output test))
(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))])
Expand Down
68 changes: 55 additions & 13 deletions drracket/drracket/private/syncheck/gui.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -753,7 +753,9 @@ If the namespace does not, they are colored the unbound color.
(send text get-end-position)
#t))
(unless (null? binding-identifiers)
(define name-to-offer (find-name-to-offer binding-identifiers))
(define name-to-offer (find-name-to-offer binding-identifiers
(send text get-start-position)
(send text get-end-position)))
(rename-menu-callback make-identifiers-hash
name-to-offer
binding-identifiers
Expand Down Expand Up @@ -941,19 +943,59 @@ If the namespace does not, they are colored the unbound color.
(for ([txt (in-list edit-sequence-txts)])
(send txt end-edit-sequence)))

;; find-name-to-offer : (non-empty-listof identifier?) -> string?
(define/private (find-name-to-offer binding-var-arrows)
(define longest-var-arrow
;; find-name-to-offer : (non-empty-listof identifier?) pos pos -> string?
(define/private (find-name-to-offer binding-var-arrows start-sel end-sel)
;; NOTE: for consistency, try to match how selection currently works
;; in DrRacket, even though it is potentially buggy. See issue #414.
;;
;; Find an identifier in either binding and bound occurrences
;; of binding-var-arrows that overlaps the selection
;; {start-sel, ..., end-sel}
;;
;; Consider an identifier `xy` at the position [10,12),
;; the following selections are considered overlapped:
;;
;; - {10,11,12} = [xy]
;; - {10} = |xy
;; - {11} = x|y
;; - {9,10} = [ ]xy
;; - {11,12} = x[y]
;;
;; and the following selections are not considered overlapped:
;;
;; - {12} = xy|
;; - {12,13} = xy[ ]
;;
;; In general, for an identifier at position [a,b), any selection
;; that intersects {a,...,b-1} is considered overlapped.
;;
;; The above behavior is for keybinding. Right click is similar
;; but if the position is between two text positions, it will
;; choose the left one.

(define (intersect? _text a b)
(define b* (sub1 b))
;; does {a,...,b*} intersect {start-sel,...,end-sel}?
(<= (max a start-sel) (min b* end-sel)))

(define ids
(for*/list ([arrow (in-list binding-var-arrows)]
[id (in-list (list (list (var-arrow-start-text arrow)
(var-arrow-start-pos-left arrow)
(var-arrow-start-pos-right arrow))
(list (var-arrow-end-text arrow)
(var-arrow-end-pos-left arrow)
(var-arrow-end-pos-right arrow))))]
#:when (apply intersect? id))
id))
(match-define (list longest-text longest-left longest-right)
(car
(sort binding-var-arrows
(sort ids
>
#:key (λ (x) (- (var-arrow-start-pos-right x)
(var-arrow-start-pos-left x))))))
(send (var-arrow-start-text longest-var-arrow)
get-text
(var-arrow-start-pos-left longest-var-arrow)
(var-arrow-start-pos-right longest-var-arrow)))

#:key (λ (x)
(match-define (list _ left right) x)
(- right left)))))
(send longest-text get-text longest-left longest-right))

;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>)
(define/private (find-menu-parent menu)
Expand Down Expand Up @@ -1477,7 +1519,7 @@ If the namespace does not, they are colored the unbound color.
(define-values (binding-identifiers make-identifiers-hash)
(position->matching-identifiers-hash text pos pos #t))
(unless (null? binding-identifiers)
(define name-to-offer (find-name-to-offer binding-identifiers))
(define name-to-offer (find-name-to-offer binding-identifiers pos pos))
(new menu-item%
[parent menu]
[label (fw:gui-utils:format-literal-label (string-constant cs-rename-var)
Expand Down