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

59
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/contract
racket/class
racket/list
racket/promise
racket/dict
racket/set
racket/runtime-path
racket/place
data/interval-map
data/union-find
drracket/tool
syntax/toplevel
mrlib/switchable-button
@ -215,7 +212,7 @@ If the namespace does not, they are colored the unbound color.
(define-struct (var-arrow arrow)
(start-text start-pos-left start-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)
(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)
(position->matching-identifiers-hash text
(send text get-start-position)
(send text get-end-position)))
(send text get-end-position)
#t))
(unless (null? binding-identifiers)
(define name-to-offer (find-name-to-offer binding-identifiers))
(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
end-text end-pos-left end-pos-right
actual? level)
(printf "hello?!\n")
(for ([x (in-list (continuation-mark-set->context
(current-continuation-marks)))])
(printf " ~s\n" x))
(printf "\n")
(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')
(define/public (syncheck:add-arrow/name-dup start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right
actual? level name-dup?)
actual? level require-arrow? name-dup?)
(when (and arrow-records
(preferences:get 'drracket:syncheck:show-arrows?))
(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)
(let ([arrow (make-var-arrow start-text start-pos-left start-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 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))
(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)
(define name-to-offer (find-name-to-offer binding-identifiers))
(new menu-item%
@ -1298,7 +1291,8 @@ If the namespace does not, they are colored the unbound color.
(set! current-matching-identifiers
(if (and cursor-text cursor-pos)
(let-values ([(_binders hash) (position->matching-identifiers-hash
cursor-text cursor-pos cursor-pos)])
cursor-text cursor-pos cursor-pos
#f)])
hash)
(make-hash)))
@ -1308,8 +1302,12 @@ If the namespace does not, they are colored the unbound color.
(send txt end-edit-sequence)))
;; 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 (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))])
(define arrs (fetch-arrow-records the-text the-pos))
(when arrs
@ -1321,7 +1319,7 @@ If the namespace does not, they are colored the unbound color.
the-pos
(var-arrow-start-pos-right arrow)))
;; a binding occurrence => keep it
(set! binding-arrows (cons arrow binding-arrows))]
(add-binding-arrow arrow)]
[else
;; a bound occurrence => find binders
(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))
(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)))
(set! binding-arrows (cons candidate-binder binding-arrows)))))])))))
(add-binding-arrow candidate-binder))))])))))
(define identifiers-hash (make-hash))
(define (add-one txt start end)
@ -1345,15 +1342,17 @@ If the namespace does not, they are colored the unbound color.
(for ([arrow (in-list (fetch-arrow-records (var-arrow-start-text binding-arrow)
pos))])
(when (var-arrow? arrow)
(when (and (equal? (var-arrow-start-text arrow)
(var-arrow-start-text binding-arrow))
(equal? (var-arrow-start-pos-left arrow)
(var-arrow-start-pos-left binding-arrow))
(equal? (var-arrow-start-pos-right arrow)
(var-arrow-start-pos-right binding-arrow)))
(add-one (var-arrow-end-text arrow)
(var-arrow-end-pos-left arrow)
(var-arrow-end-pos-right arrow)))))))
(when (or include-require-arrows?
(not (var-arrow-require-arrow? arrow)))
(when (and (equal? (var-arrow-start-text arrow)
(var-arrow-start-text binding-arrow))
(equal? (var-arrow-start-pos-left arrow)
(var-arrow-start-pos-left binding-arrow))
(equal? (var-arrow-start-pos-right arrow)
(var-arrow-start-pos-right binding-arrow)))
(add-one (var-arrow-end-text arrow)
(var-arrow-end-pos-left arrow)
(var-arrow-end-pos-right arrow))))))))
(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
;; callback for the jump popup menu item
(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
(sort (hash-map identifiers-hash
(λ (x y) x))
@ -1848,12 +1847,12 @@ If the namespace does not, they are colored the unbound color.
(match x
[`#(syncheck:add-arrow/name-dup ,start-pos-left ,start-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))
(send defs-text syncheck:add-arrow/name-dup
defs-text start-pos-left start-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)
(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)

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

@ -50,7 +50,7 @@
(void))
(define/public (syncheck:add-arrow/name-dup start-text start-pos-left start-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
end-text end-pos-left end-pos-right
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
_end-text end-pos-left end-pos-right
actual? level name-dup?)
actual? level require-arrow? name-dup?)
(define id (hash-count table))
(hash-set! table id name-dup?)
(add-to-trace (vector 'syncheck:add-arrow/name-dup
start-pos-left start-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-mouse-over-status _text pos-left pos-right str)
(log syncheck:add-background-color _text color start fin)

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

@ -12,17 +12,15 @@
racket/set
racket/class
racket/list
racket/contract
syntax/boundmap
framework/preferences
scribble/manual-struct)
(provide make-traversal
current-max-to-send-at-once)
(define current-max-to-send-at-once (make-parameter +inf.0))
;
;
;
@ -590,7 +588,7 @@
(define binders (get-ids all-binders var))
(when 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)
(define req-path/pr (get-module-req-path var phase-level))
@ -630,7 +628,8 @@
req-stx)
var actual? all-binders
(id-level phase-level var)
connections))))))))
connections
#t))))))))
(define (id/require-match? var id req-stx)
(match req-stx
@ -764,7 +763,7 @@
;; connect-syntaxes : syntax[original] syntax[original] boolean symbol connections -> void
;; 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)]
[to-source (find-source-editor to)]
[defs-text (current-annotations)])
@ -804,7 +803,7 @@
(send defs-text syncheck:add-arrow/name-dup
from-source from-pos-left from-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
;; 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?]
[actual? boolean?]
[phase-level (or/c exact-nonnegative-integer? #f)]
[require-arrow? boolean?]
[name-dup? (-> string? boolean?)])
void?]{
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
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]
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
@ -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]
method ignores its arguments and returns @racket[#f];}
@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}
@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
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
syncheck-example-eval
(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
start-source-obj start-left start-right
end-source-obj end-left end-right
actual? phase-level name-dup?)
actual? phase-level require-arrow? name-dup?)
(set! arrows
(cons (list start-source-obj end-source-obj)
arrows)))