suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust check syntax so it highlights all identifiers with the same

Browse Source 
binding site (with a green/yellow bubble) when the mouse moves over
any one of them

This change comes about because of the recent fixes to the
interactivity wrt to the rename menu. Basically, in order to fix the
bug (but still preserve the interactivity optimization), check syntax
changed from sending the information "here is a place to offer a
rename for these identifiers" to "here is a set of identifiers that
are all free-identifier=?" (the difference being that the latter does
not imply you got them all (which enables the optimization) and that
the information is slightly less rename-menu specific (which enables
the change in this commit))
This commit is contained in:
Robby Findler 2013-01-31 08:55:00 -06:00
parent b4ec1de386
commit a3cde5fb42
1 changed files with 128 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
collects/drracket/private/syncheck/gui.rkt
View File

@ -369,6 +369,13 @@ If the namespace does not, they are colored the unbound color.
(define arrow-records #f)
(define/private (fetch-arrow-records txt pos)
(and arrow-records
(let ([im (hash-ref arrow-records txt #f)])
(if im
(interval-map-ref im pos '())
'()))))
(define/public (dump-arrow-records)
(cond
[arrow-records
@ -665,7 +672,7 @@ If the namespace does not, they are colored the unbound color.
;; callback for the rename popup menu item
(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
(define new-str
(fw:keymap:call/text-keymap-initializer
(λ ()
(get-text-from-user
@ -673,7 +680,7 @@ If the namespace does not, they are colored the unbound color.
(fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer)
parent
name-to-offer
#:dialog-mixin frame:focus-table-mixin)))])
#:dialog-mixin frame:focus-table-mixin))))
(when new-str
(define new-sym (format "~s" (string->symbol new-str)))
(define dup-name? (name-dup? new-sym))
@ -694,7 +701,7 @@ If the namespace does not, they are colored the unbound color.
1)))
(when do-renaming?
(let ([txts (list this)])
(define txts (list this))
(define positions-to-rename
(remove-duplicates
(sort (set->list (uf-find
@ -715,7 +722,7 @@ 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<%>)
@ -889,7 +896,7 @@ If the namespace does not, they are colored the unbound color.
(define scrolled? (update-view-corner admin))
;; when painting on the canvas the mouse is over...
(when (eq? mouse-admin admin)
(define update-tooltip-frame?
(define update-tooltip-frame-and-matching-identifiers?
(cond
;; turn off arrows immediately if scrolling
[scrolled? (set! cursor-tooltip #f)
@ -904,8 +911,8 @@ If the namespace does not, they are colored the unbound color.
(set! cursor-tooltip (get-tooltip cursor-eles))
(not (eq? cursor-tooltip 'out-of-sync))]
[else #f]))
(when update-tooltip-frame?
(update-tooltip-frame))
(when update-tooltip-frame-and-matching-identifiers?
(update-tooltip-frame-and-matching-identifiers))
;; update on a timer if the arrows changed
(when (update-latent-arrows mouse-x mouse-y)
(start-arrow-draw-timer syncheck-arrow-delay)))
@ -953,10 +960,10 @@ If the namespace does not, they are colored the unbound color.
(draw-arrow2 arrow))))
(when (and cursor-pos
cursor-text)
(define arrow-record (hash-ref arrow-records cursor-text #f))
(define arrow-records-at-cursor (fetch-arrow-records cursor-text cursor-pos))
(define tail-arrows '())
(when arrow-record
(for ([ele (in-list (interval-map-ref arrow-record cursor-pos null))])
(when arrow-records-at-cursor
(for ([ele (in-list arrow-records-at-cursor)])
(cond [(var-arrow? ele)
(if (var-arrow-actual? ele)
(begin (send dc set-pen (get-var-pen white-on-black?))
@ -1094,18 +1101,11 @@ If the namespace does not, they are colored the unbound color.
(set! cursor-eles latent-eles)
(set! cursor-tooltip latent-tooltip)
(update-tooltip-frame)
(update-tooltip-frame-and-matching-identifiers)
(update-docs-background cursor-eles)
(unless (equal? latent-stuff cursor-stuff)
(invalidate-bitmap-cache)))
(define/private (fetch-arrow-records txt pos)
(and arrow-records
(let ([im (hash-ref arrow-records txt #f)])
(if im
(interval-map-ref im pos '())
'()))))
(define mouse-admin #f) ; editor admin for the last mouse move
(define mouse-x #f) ; last known mouse position
(define mouse-y #f)
@ -1221,6 +1221,10 @@ If the namespace does not, they are colored the unbound color.
(make-rename-menu menu identifier-location-set/f))
(void))))
(define/private (update-tooltip-frame-and-matching-identifiers)
(update-tooltip-frame)
(update-matching-identifiers))
(define tooltip-frame #f)
(define/private (update-tooltip-frame)
(unless tooltip-frame (set! tooltip-frame (new tooltip-frame%)))
@ -1233,6 +1237,41 @@ If the namespace does not, they are colored the unbound color.
;; #f or 'out-of-sync
[_ (send tooltip-frame show #f)]))
(define current-matching-identifiers (set))
(define/private (update-matching-identifiers)
(define arrow-records (fetch-arrow-records cursor-text cursor-pos))
(define id-set (if arrow-records
(let ([an-identifier-location-set
(for/or ([x (in-list arrow-records)])
(and (identifier-location-set? x)
x))])
(if an-identifier-location-set
(uf-find (identifier-location-set-set
an-identifier-location-set))
(set)))
(set)))
(define clr "GreenYellow")
(define style 'ellipse)
(unless (equal? current-matching-identifiers id-set)
(define in-edit-sequence (list this))
(begin-edit-sequence)
(define (uh/highlight highlight?)
(for ([lst (in-set current-matching-identifiers)])
(define txt (list-ref lst 0))
(define start (list-ref lst 1))
(define end (list-ref lst 2))
(unless (member txt in-edit-sequence)
(set! in-edit-sequence (cons txt in-edit-sequence))
(send txt begin-edit-sequence))
(if highlight?
(send txt highlight-range start end clr #f 'low style)
(send txt unhighlight-range start end clr #f style))))
(uh/highlight #f)
(set! current-matching-identifiers id-set)
(uh/highlight #t)
(for ([x (in-list in-edit-sequence)])
(send x end-edit-sequence))))
;; Sometimes when this is called, the calls to 'tooltip-info->ltrb'
;; fail and we get no information back. When that happens, we return
;; 'out-of-sync and try again in on-paint (which happens every time