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

217
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 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) (define/public (dump-arrow-records)
(cond (cond
[arrow-records [arrow-records
@ -656,85 +663,85 @@ If the namespace does not, they are colored the unbound color.
name-to-offer name-to-offer
an-identifier-location-set)))])) an-identifier-location-set)))]))
;; rename-callback : string ;; rename-callback : string
;; (and/c syncheck-text<%> definitions-text<%>) ;; (and/c syncheck-text<%> definitions-text<%>)
;; (list source number number) ;; (list source number number)
;; (listof id-set) ;; (listof id-set)
;; (union #f (is-a?/c top-level-window<%>)) ;; (union #f (is-a?/c top-level-window<%>))
;; -> void ;; -> void
;; callback for the rename popup menu item ;; callback for the rename popup menu item
(define/private (rename-menu-callback parent name-to-offer an-identifier-location-set) (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)) (define name-dup? (identifier-location-set-name-dup? an-identifier-location-set))
(let ([new-str (define new-str
(fw:keymap:call/text-keymap-initializer (fw:keymap:call/text-keymap-initializer
(λ () (λ ()
(get-text-from-user (get-text-from-user
(string-constant cs-rename-id) (string-constant cs-rename-id)
(fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer) (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer)
parent parent
name-to-offer name-to-offer
#:dialog-mixin frame:focus-table-mixin)))]) #:dialog-mixin frame:focus-table-mixin))))
(when new-str (when new-str
(define new-sym (format "~s" (string->symbol new-str))) (define new-sym (format "~s" (string->symbol new-str)))
(define dup-name? (name-dup? new-sym)) (define dup-name? (name-dup? new-sym))
(define do-renaming? (define do-renaming?
(or (not dup-name?) (or (not dup-name?)
(equal? (equal?
(message-box/custom (message-box/custom
(string-constant check-syntax) (string-constant check-syntax)
(fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error)
new-sym) new-sym)
(string-constant cs-rename-anyway) (string-constant cs-rename-anyway)
(string-constant cancel) (string-constant cancel)
#f #f
parent parent
'(stop default=2) '(stop default=2)
#:dialog-mixin frame:focus-table-mixin) #:dialog-mixin frame:focus-table-mixin)
1))) 1)))
(when do-renaming? (when do-renaming?
(let ([txts (list this)]) (define txts (list this))
(define positions-to-rename (define positions-to-rename
(remove-duplicates (remove-duplicates
(sort (set->list (uf-find (sort (set->list (uf-find
(identifier-location-set-set (identifier-location-set-set
an-identifier-location-set))) an-identifier-location-set)))
> >
#:key cadr))) #:key cadr)))
(begin-edit-sequence) (begin-edit-sequence)
(for ([info (in-list positions-to-rename)]) (for ([info (in-list positions-to-rename)])
(define source-editor (list-ref info 0)) (define source-editor (list-ref info 0))
(define start (list-ref info 1)) (define start (list-ref info 1))
(define end (list-ref info 2)) (define end (list-ref info 2))
(when (is-a? source-editor text%) (when (is-a? source-editor text%)
(unless (memq source-editor txts) (unless (memq source-editor txts)
(send source-editor begin-edit-sequence) (send source-editor begin-edit-sequence)
(set! txts (cons source-editor txts))) (set! txts (cons source-editor txts)))
(send source-editor delete start end #f) (send source-editor delete start end #f)
(send source-editor insert new-sym start start #f))) (send source-editor insert new-sym start start #f)))
(invalidate-bitmap-cache) (invalidate-bitmap-cache)
(for ([txt (in-list txts)]) (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<%>) ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>)
(define/private (find-menu-parent menu) (define/private (find-menu-parent menu)
(let loop ([menu menu]) (let loop ([menu menu])
(cond (cond
[(is-a? menu menu-bar%) (send menu get-frame)] [(is-a? menu menu-bar%) (send menu get-frame)]
[(is-a? menu popup-menu%) [(is-a? menu popup-menu%)
(let ([target (send menu get-popup-target)]) (let ([target (send menu get-popup-target)])
(cond (cond
[(is-a? target editor<%>) [(is-a? target editor<%>)
(let ([canvas (send target get-canvas)]) (let ([canvas (send target get-canvas)])
(and canvas (and canvas
(send canvas get-top-level-window)))] (send canvas get-top-level-window)))]
[(is-a? target window<%>) [(is-a? target window<%>)
(send target get-top-level-window)] (send target get-top-level-window)]
[else #f]))] [else #f]))]
[(is-a? menu menu-item<%>) (loop (send menu get-parent))] [(is-a? menu menu-item<%>) (loop (send menu get-parent))]
[else #f]))) [else #f])))
(define/private (syncheck:add-menu text start-pos end-pos key make-menu) (define/private (syncheck:add-menu text start-pos end-pos key make-menu)
(when arrow-records (when arrow-records
@ -889,7 +896,7 @@ If the namespace does not, they are colored the unbound color.
(define scrolled? (update-view-corner admin)) (define scrolled? (update-view-corner admin))
;; when painting on the canvas the mouse is over... ;; when painting on the canvas the mouse is over...
(when (eq? mouse-admin admin) (when (eq? mouse-admin admin)
(define update-tooltip-frame? (define update-tooltip-frame-and-matching-identifiers?
(cond (cond
;; turn off arrows immediately if scrolling ;; turn off arrows immediately if scrolling
[scrolled? (set! cursor-tooltip #f) [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)) (set! cursor-tooltip (get-tooltip cursor-eles))
(not (eq? cursor-tooltip 'out-of-sync))] (not (eq? cursor-tooltip 'out-of-sync))]
[else #f])) [else #f]))
(when update-tooltip-frame? (when update-tooltip-frame-and-matching-identifiers?
(update-tooltip-frame)) (update-tooltip-frame-and-matching-identifiers))
;; update on a timer if the arrows changed ;; update on a timer if the arrows changed
(when (update-latent-arrows mouse-x mouse-y) (when (update-latent-arrows mouse-x mouse-y)
(start-arrow-draw-timer syncheck-arrow-delay))) (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)))) (draw-arrow2 arrow))))
(when (and cursor-pos (when (and cursor-pos
cursor-text) 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 '()) (define tail-arrows '())
(when arrow-record (when arrow-records-at-cursor
(for ([ele (in-list (interval-map-ref arrow-record cursor-pos null))]) (for ([ele (in-list arrow-records-at-cursor)])
(cond [(var-arrow? ele) (cond [(var-arrow? ele)
(if (var-arrow-actual? ele) (if (var-arrow-actual? ele)
(begin (send dc set-pen (get-var-pen white-on-black?)) (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-eles latent-eles)
(set! cursor-tooltip latent-tooltip) (set! cursor-tooltip latent-tooltip)
(update-tooltip-frame) (update-tooltip-frame-and-matching-identifiers)
(update-docs-background cursor-eles) (update-docs-background cursor-eles)
(unless (equal? latent-stuff cursor-stuff) (unless (equal? latent-stuff cursor-stuff)
(invalidate-bitmap-cache))) (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-admin #f) ; editor admin for the last mouse move
(define mouse-x #f) ; last known mouse position (define mouse-x #f) ; last known mouse position
(define mouse-y #f) (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)) (make-rename-menu menu identifier-location-set/f))
(void)))) (void))))
(define/private (update-tooltip-frame-and-matching-identifiers)
(update-tooltip-frame)
(update-matching-identifiers))
(define tooltip-frame #f) (define tooltip-frame #f)
(define/private (update-tooltip-frame) (define/private (update-tooltip-frame)
(unless tooltip-frame (set! tooltip-frame (new 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 ;; #f or 'out-of-sync
[_ (send tooltip-frame show #f)])) [_ (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' ;; Sometimes when this is called, the calls to 'tooltip-info->ltrb'
;; fail and we get no information back. When that happens, we return ;; 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 ;; 'out-of-sync and try again in on-paint (which happens every time