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

dont draw the lime green bubbles for imported identifiers

Browse Source 
One problem with commit 299063d7c1
is that the new method for computing the lime green arrows no
longer has the information necessary to distinguish different
identifiers that come from the same require.

This means that, before this commit, mousing over an imported
identifier can be a real interactivity killer. So, instead of
adding more information to distinguish those ids, lets just
try not draw the lime green bubbles for imported identifiers
and see how that feels
This commit is contained in:
Robby Findler 2013-05-20 10:07:46 -05:00
parent 0ca35b1f6a
commit d381eb5051
5 changed files with 50 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -23,14 +23,11 @@ If the namespace does not, they are colored the unbound color.
racket/match racket/match
racket/contract racket/contract
racket/class racket/class
racket/list
racket/promise
racket/dict racket/dict
racket/set racket/set
racket/runtime-path racket/runtime-path
racket/place racket/place
data/interval-map data/interval-map
data/union-find
drracket/tool drracket/tool
syntax/toplevel syntax/toplevel
mrlib/switchable-button mrlib/switchable-button
@ -215,7 +212,7 @@ If the namespace does not, they are colored the unbound color.
(define-struct (var-arrow arrow) (define-struct (var-arrow arrow)
(start-text start-pos-left start-pos-right (start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right end-text end-pos-left end-pos-right
actual? level name-dup?) ;; level is one of 'lexical, 'top-level, 'import actual? level require-arrow? name-dup?) ;; level is one of 'lexical, 'top-level, 'import
#:transparent) #:transparent)
(define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos) #:transparent) (define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos) #:transparent)
@ -665,7 +662,8 @@ If the namespace does not, they are colored the unbound color.
(define-values (binding-identifiers identifiers-hash) (define-values (binding-identifiers identifiers-hash)
(position->matching-identifiers-hash text (position->matching-identifiers-hash text
(send text get-start-position) (send text get-start-position)
(send text get-end-position))) (send text get-end-position)
#t))
(unless (null? binding-identifiers) (unless (null? binding-identifiers)
(define name-to-offer (find-name-to-offer binding-identifiers)) (define name-to-offer (find-name-to-offer binding-identifiers))
(rename-menu-callback identifiers-hash (rename-menu-callback identifiers-hash
@ -803,18 +801,13 @@ If the namespace does not, they are colored the unbound color.
(define/public (syncheck:add-arrow start-text start-pos-left start-pos-right (define/public (syncheck:add-arrow start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right end-text end-pos-left end-pos-right
actual? level) actual? level)
(printf "hello?!\n")
(for ([x (in-list (continuation-mark-set->context
(current-continuation-marks)))])
(printf " ~s\n" x))
(printf "\n")
(void)) (void))
;; syncheck:add-arrow : symbol text number number text number number boolean -> void ;; syncheck:add-arrow : symbol text number number text number number boolean -> void
;; pre: start-editor, end-editor are embedded in `this' (or are `this') ;; pre: start-editor, end-editor are embedded in `this' (or are `this')
(define/public (syncheck:add-arrow/name-dup start-text start-pos-left start-pos-right (define/public (syncheck:add-arrow/name-dup start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right end-text end-pos-left end-pos-right
actual? level name-dup?) actual? level require-arrow? name-dup?)
(when (and arrow-records (when (and arrow-records
(preferences:get 'drracket:syncheck:show-arrows?)) (preferences:get 'drracket:syncheck:show-arrows?))
(when (add-to-bindings-table (when (add-to-bindings-table
@ -822,7 +815,7 @@ If the namespace does not, they are colored the unbound color.
end-text end-pos-left end-pos-right) end-text end-pos-left end-pos-right)
(let ([arrow (make-var-arrow start-text start-pos-left start-pos-right (let ([arrow (make-var-arrow start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right end-text end-pos-left end-pos-right
actual? level name-dup?)]) actual? level require-arrow? name-dup?)])
(add-to-range/key start-text start-pos-left start-pos-right arrow #f #f) (add-to-range/key start-text start-pos-left start-pos-right arrow #f #f)
(add-to-range/key end-text end-pos-left end-pos-right arrow #f #f))))) (add-to-range/key end-text end-pos-left end-pos-right arrow #f #f)))))
@ -1241,7 +1234,7 @@ If the namespace does not, they are colored the unbound color.
(f menu)) (f menu))
(define-values (binding-identifiers identifiers-hash) (define-values (binding-identifiers identifiers-hash)
(position->matching-identifiers-hash text pos (+ pos 1))) (position->matching-identifiers-hash text pos (+ pos 1) #t))
(unless (null? binding-identifiers) (unless (null? binding-identifiers)
(define name-to-offer (find-name-to-offer binding-identifiers)) (define name-to-offer (find-name-to-offer binding-identifiers))
(new menu-item% (new menu-item%
@ -1298,7 +1291,8 @@ If the namespace does not, they are colored the unbound color.
(set! current-matching-identifiers (set! current-matching-identifiers
(if (and cursor-text cursor-pos) (if (and cursor-text cursor-pos)
(let-values ([(_binders hash) (position->matching-identifiers-hash (let-values ([(_binders hash) (position->matching-identifiers-hash
cursor-text cursor-pos cursor-pos)]) cursor-text cursor-pos cursor-pos
#f)])
hash) hash)
(make-hash))) (make-hash)))
@ -1308,8 +1302,12 @@ If the namespace does not, they are colored the unbound color.
(send txt end-edit-sequence))) (send txt end-edit-sequence)))
;; position->matching-identifiers-hash : txt pos pos -> (values (listof var-arrow?) hash[(list txt pos pos) -o> #t]) ;; position->matching-identifiers-hash : txt pos pos -> (values (listof var-arrow?) hash[(list txt pos pos) -o> #t])
(define/private (position->matching-identifiers-hash the-text the-start-pos the-end-pos) (define/private (position->matching-identifiers-hash the-text the-start-pos the-end-pos include-require-arrows?)
(define binding-arrows '()) (define binding-arrows '())
(define (add-binding-arrow arr)
(when (or include-require-arrows?
(not (var-arrow-require-arrow? arr)))
(set! binding-arrows (cons arr binding-arrows))))
(for ([the-pos (in-range the-start-pos (+ the-end-pos 1))]) (for ([the-pos (in-range the-start-pos (+ the-end-pos 1))])
(define arrs (fetch-arrow-records the-text the-pos)) (define arrs (fetch-arrow-records the-text the-pos))
(when arrs (when arrs
@ -1321,7 +1319,7 @@ If the namespace does not, they are colored the unbound color.
the-pos the-pos
(var-arrow-start-pos-right arrow))) (var-arrow-start-pos-right arrow)))
;; a binding occurrence => keep it ;; a binding occurrence => keep it
(set! binding-arrows (cons arrow binding-arrows))] (add-binding-arrow arrow)]
[else [else
;; a bound occurrence => find binders ;; a bound occurrence => find binders
(for ([candidate-binder (in-list (fetch-arrow-records (var-arrow-start-text arrow) (for ([candidate-binder (in-list (fetch-arrow-records (var-arrow-start-text arrow)
@ -1330,8 +1328,7 @@ If the namespace does not, they are colored the unbound color.
(when (and (equal? (var-arrow-start-text arrow) (var-arrow-start-text candidate-binder)) (when (and (equal? (var-arrow-start-text arrow) (var-arrow-start-text candidate-binder))
(equal? (var-arrow-start-pos-left arrow) (var-arrow-start-pos-left candidate-binder)) (equal? (var-arrow-start-pos-left arrow) (var-arrow-start-pos-left candidate-binder))
(equal? (var-arrow-start-pos-right arrow) (var-arrow-start-pos-right candidate-binder))) (equal? (var-arrow-start-pos-right arrow) (var-arrow-start-pos-right candidate-binder)))
(set! binding-arrows (cons candidate-binder binding-arrows)))))]))))) (add-binding-arrow candidate-binder))))])))))
(define identifiers-hash (make-hash)) (define identifiers-hash (make-hash))
(define (add-one txt start end) (define (add-one txt start end)
@ -1345,6 +1342,8 @@ If the namespace does not, they are colored the unbound color.
(for ([arrow (in-list (fetch-arrow-records (var-arrow-start-text binding-arrow) (for ([arrow (in-list (fetch-arrow-records (var-arrow-start-text binding-arrow)
pos))]) pos))])
(when (var-arrow? arrow) (when (var-arrow? arrow)
(when (or include-require-arrows?
(not (var-arrow-require-arrow? arrow)))
(when (and (equal? (var-arrow-start-text arrow) (when (and (equal? (var-arrow-start-text arrow)
(var-arrow-start-text binding-arrow)) (var-arrow-start-text binding-arrow))
(equal? (var-arrow-start-pos-left arrow) (equal? (var-arrow-start-pos-left arrow)
@ -1353,7 +1352,7 @@ If the namespace does not, they are colored the unbound color.
(var-arrow-start-pos-right binding-arrow))) (var-arrow-start-pos-right binding-arrow)))
(add-one (var-arrow-end-text arrow) (add-one (var-arrow-end-text arrow)
(var-arrow-end-pos-left arrow) (var-arrow-end-pos-left arrow)
(var-arrow-end-pos-right arrow))))))) (var-arrow-end-pos-right arrow))))))))
(values binding-arrows identifiers-hash)) (values binding-arrows identifiers-hash))
@ -1533,7 +1532,7 @@ If the namespace does not, they are colored the unbound color.
;; jump-to-next-callback : num text boolean? -> void ;; jump-to-next-callback : num text boolean? -> void
;; callback for the jump popup menu item ;; callback for the jump popup menu item
(define/private (jump-to-next-callback start-pos end-pos txt backwards?) (define/private (jump-to-next-callback start-pos end-pos txt backwards?)
(define-values (_binders identifiers-hash) (position->matching-identifiers-hash txt start-pos end-pos)) (define-values (_binders identifiers-hash) (position->matching-identifiers-hash txt start-pos end-pos #t))
(define orig-arrows (define orig-arrows
(sort (hash-map identifiers-hash (sort (hash-map identifiers-hash
(λ (x y) x)) (λ (x y) x))
@ -1848,12 +1847,12 @@ If the namespace does not, they are colored the unbound color.
(match x (match x
[`#(syncheck:add-arrow/name-dup ,start-pos-left ,start-pos-right [`#(syncheck:add-arrow/name-dup ,start-pos-left ,start-pos-right
,end-pos-left ,end-pos-right ,end-pos-left ,end-pos-right
,actual? ,level ,name-dup-pc ,name-dup-id) ,actual? ,level ,require-arrow? ,name-dup-pc ,name-dup-id)
(define name-dup? (build-name-dup? name-dup-pc name-dup-id)) (define name-dup? (build-name-dup? name-dup-pc name-dup-id))
(send defs-text syncheck:add-arrow/name-dup (send defs-text syncheck:add-arrow/name-dup
defs-text start-pos-left start-pos-right defs-text start-pos-left start-pos-right
defs-text end-pos-left end-pos-right defs-text end-pos-left end-pos-right
actual? level name-dup?)] actual? level require-arrow? name-dup?)]
[`#(syncheck:add-tail-arrow ,from-pos ,to-pos) [`#(syncheck:add-tail-arrow ,from-pos ,to-pos)
(send defs-text syncheck:add-tail-arrow defs-text from-pos defs-text to-pos)] (send defs-text syncheck:add-tail-arrow defs-text from-pos defs-text to-pos)]
[`#(syncheck:add-mouse-over-status ,pos-left ,pos-right ,str) [`#(syncheck:add-mouse-over-status ,pos-left ,pos-right ,str)

2
collects/drracket/private/syncheck/intf.rkt
View File

@ -50,7 +50,7 @@
(void)) (void))
(define/public (syncheck:add-arrow/name-dup start-text start-pos-left start-pos-right (define/public (syncheck:add-arrow/name-dup start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right end-text end-pos-left end-pos-right
actual? level name-dup?) actual? level require-arrow? name-dup?)
(syncheck:add-arrow start-text start-pos-left start-pos-right (syncheck:add-arrow start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right end-text end-pos-left end-pos-right
actual? level)) actual? level))

4
collects/drracket/private/syncheck/online-comp.rkt
View File

@ -36,13 +36,13 @@
(define/override (syncheck:add-arrow/name-dup _start-text start-pos-left start-pos-right (define/override (syncheck:add-arrow/name-dup _start-text start-pos-left start-pos-right
_end-text end-pos-left end-pos-right _end-text end-pos-left end-pos-right
actual? level name-dup?) actual? level require-arrow? name-dup?)
(define id (hash-count table)) (define id (hash-count table))
(hash-set! table id name-dup?) (hash-set! table id name-dup?)
(add-to-trace (vector 'syncheck:add-arrow/name-dup (add-to-trace (vector 'syncheck:add-arrow/name-dup
start-pos-left start-pos-right start-pos-left start-pos-right
end-pos-left end-pos-right end-pos-left end-pos-right
actual? level remote-chan id))) actual? level require-arrow? remote-chan id)))
(log syncheck:add-tail-arrow _from-text from-pos _to-text to-pos) (log syncheck:add-tail-arrow _from-text from-pos _to-text to-pos)
(log syncheck:add-mouse-over-status _text pos-left pos-right str) (log syncheck:add-mouse-over-status _text pos-left pos-right str)
(log syncheck:add-background-color _text color start fin) (log syncheck:add-background-color _text color start fin)

11
collects/drracket/private/syncheck/traversals.rkt
View File

@ -12,9 +12,7 @@
racket/set racket/set
racket/class racket/class
racket/list racket/list
racket/contract
syntax/boundmap syntax/boundmap
framework/preferences
scribble/manual-struct) scribble/manual-struct)
(provide make-traversal (provide make-traversal
@ -590,7 +588,7 @@
(define binders (get-ids all-binders var)) (define binders (get-ids all-binders var))
(when binders (when binders
(for ([x (in-list binders)]) (for ([x (in-list binders)])
(connect-syntaxes x var actual? all-binders (id-level phase-level x) connections))) (connect-syntaxes x var actual? all-binders (id-level phase-level x) connections #f)))
(when (and unused/phases phase-to-requires) (when (and unused/phases phase-to-requires)
(define req-path/pr (get-module-req-path var phase-level)) (define req-path/pr (get-module-req-path var phase-level))
@ -630,7 +628,8 @@
req-stx) req-stx)
var actual? all-binders var actual? all-binders
(id-level phase-level var) (id-level phase-level var)
connections)))))))) connections
#t))))))))
(define (id/require-match? var id req-stx) (define (id/require-match? var id req-stx)
(match req-stx (match req-stx
@ -764,7 +763,7 @@
;; connect-syntaxes : syntax[original] syntax[original] boolean symbol connections -> void ;; connect-syntaxes : syntax[original] syntax[original] boolean symbol connections -> void
;; adds an arrow from `from' to `to', unless they have the same source loc. ;; adds an arrow from `from' to `to', unless they have the same source loc.
(define (connect-syntaxes from to actual? all-binders level connections) (define (connect-syntaxes from to actual? all-binders level connections require-arrow?)
(let ([from-source (find-source-editor from)] (let ([from-source (find-source-editor from)]
[to-source (find-source-editor to)] [to-source (find-source-editor to)]
[defs-text (current-annotations)]) [defs-text (current-annotations)])
@ -804,7 +803,7 @@
(send defs-text syncheck:add-arrow/name-dup (send defs-text syncheck:add-arrow/name-dup
from-source from-pos-left from-pos-right from-source from-pos-left from-pos-right
to-source to-pos-left to-pos-right to-source to-pos-left to-pos-right
actual? level name-dup?)))))))) actual? level require-arrow? name-dup?))))))))
;; add-jump-to-definition : syntax symbol path -> void ;; add-jump-to-definition : syntax symbol path -> void
;; registers the range in the editor so that the ;; registers the range in the editor so that the

14
collects/scribblings/tools/tools.scrbl
View File

@ -744,6 +744,7 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
[end-right exact-nonnegative-integer?] [end-right exact-nonnegative-integer?]
[actual? boolean?] [actual? boolean?]
[phase-level (or/c exact-nonnegative-integer? #f)] [phase-level (or/c exact-nonnegative-integer? #f)]
[require-arrow? boolean?]
[name-dup? (-> string? boolean?)]) [name-dup? (-> string? boolean?)])
void?]{ void?]{
Called to indicate that there should be an arrow between the locations described by the first six arguments. Called to indicate that there should be an arrow between the locations described by the first six arguments.
@ -752,6 +753,9 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
indicates if the binding is a real one, or a predicted one from a syntax template (predicted bindings indicates if the binding is a real one, or a predicted one from a syntax template (predicted bindings
are drawn with question marks in Check Syntax). are drawn with question marks in Check Syntax).
The @racket[require-arrow?] argument indicates if this arrow points from
an imported identifier to its corresponding @racket[require].
The @racket[name-dup?] predicate returns @racket[#t] The @racket[name-dup?] predicate returns @racket[#t]
in case that this variable (either the start or end), when replaced with the given string, would in case that this variable (either the start or end), when replaced with the given string, would
shadow some other binding (or otherwise interfere with the binding structure of the program at shadow some other binding (or otherwise interfere with the binding structure of the program at
@ -823,13 +827,17 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
@itemlist[@item{The @method[syncheck-annotations<%> syncheck:find-source-object] @itemlist[@item{The @method[syncheck-annotations<%> syncheck:find-source-object]
method ignores its arguments and returns @racket[#f];} method ignores its arguments and returns @racket[#f];}
@item{the @method[syncheck-annotations<%> syncheck:add-arrow/name-dup] method drops the @item{the @method[syncheck-annotations<%> syncheck:add-arrow/name-dup] method drops the
@racket[_name-dup?] argument and calls @racket[_require-arrow?] and @racket[_name-dup?] arguments and calls
@method[syncheck-annotations<%> syncheck:add-arrow]; and} @method[syncheck-annotations<%> syncheck:add-arrow]; and}
@item{all of the other methods ignore their arguments and return @racket[(void)].}] @item{all of the other methods ignore their arguments and return @racket[(void)].}]
Here is an example showing how use this library to extract all Here is an example showing how use this library to extract all
of the arrows that Check Syntax would draw from various of the arrows that Check Syntax would draw from various
expressions: expressions. One subtle point: arrows are only included when
the corresponding identifiers are @racket[syntax-original?];
the code below manages this by copying the properties from
an identifier that is @racket[syntax-original?] in the
call to @racket[datum->syntax].
@interaction[#:eval @interaction[#:eval
syncheck-example-eval syncheck-example-eval
(require drracket/check-syntax racket/class) (require drracket/check-syntax racket/class)
@ -841,7 +849,7 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
(define/override (syncheck:add-arrow/name-dup (define/override (syncheck:add-arrow/name-dup
start-source-obj start-left start-right start-source-obj start-left start-right
end-source-obj end-left end-right end-source-obj end-left end-right
actual? phase-level name-dup?) actual? phase-level require-arrow? name-dup?)
(set! arrows (set! arrows
(cons (list start-source-obj end-source-obj) (cons (list start-source-obj end-source-obj)
arrows))) arrows)))