Adjusted check syntax to properly deal with different identifiers

that have overlapping ranges in the editor; also got rid of the
id-set stuff

Getting rid of the id-set information that was computed means that now
the mouse-over green bubbles, the "jump to next binding occurrence"/
"jump to bound occurrence" keybindings/menu items, and the renaming
are all being computed from the arrows information as needed, instead
of building up sets as check syntax collects information. This may
change the way Check Syntax behaves in some cases; so far the only
example I've found has been strange and are arguably for the
better. Specifically, this program

  (define-syntax-rule (m x) (λ (x) x)) (m z)

no longer draws a green bubble when you mouse over the "z", since
there are no arrows (the only arrow that might have been drawn is
discarded since its start and end points are the same place).

This speeds up the "analyze the expanded code" phase of check syntax,
making it approximately 1.6x faster than before (going from about 31
seconds to about 19 seconds for this phase for the
drracket/private/unit.rkt file (on my machine)). Also, the replay
phase is probably a bit faster now, tho, too: there were 1.07x fewer
elements to process in the trace that comes back from online check
syntax now for that same file (33063 to 30842)

Note that this is only that one phase: this doesn't count the time to
actually expand the program (the dark blue bubble phase) nor the time
to send the results between places, nor the time to replay the
collected information (the light purple bubble phase).
This commit is contained in:
Robby Findler 2013-05-18 10:11:17 -05:00
parent 3eb4a75613
commit 299063d7c1
9 changed files with 459 additions and 440 deletions

View File

@ -31,6 +31,7 @@
syncheck:add-id-set syncheck:add-id-set
syncheck:add-rename-menu syncheck:add-rename-menu
syncheck:add-arrow syncheck:add-arrow
syncheck:add-arrow/name-dup
syncheck:add-tail-arrow syncheck:add-tail-arrow
syncheck:add-mouse-over-status syncheck:add-mouse-over-status
syncheck:add-jump-to-definition syncheck:add-jump-to-definition

View File

@ -16,6 +16,7 @@ If the namespace does not, they are colored the unbound color.
|# |#
(module+ test (require rackunit))
(require string-constants (require string-constants
racket/unit racket/unit
@ -214,7 +215,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) ;; level is one of 'lexical, 'top-level, 'import actual? level 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)
@ -361,7 +362,6 @@ If the namespace does not, they are colored the unbound color.
;; - arrow ;; - arrow
;; - string ;; - string
;; - colored-region ;; - colored-region
;; - identifier-location-set
(define/private (get-arrow-record text) (define/private (get-arrow-record text)
(unless (object? text) (unless (object? text)
(error 'get-arrow-record "expected a text as the second argument, got ~e" text)) (error 'get-arrow-record "expected a text as the second argument, got ~e" text))
@ -657,49 +657,21 @@ If the namespace does not, they are colored the unbound color.
;; no longer used, but must be here for backwards compatibility ;; no longer used, but must be here for backwards compatibility
(define/public (syncheck:add-rename-menu id to-be-renamed/poss name-dup?) (void)) (define/public (syncheck:add-rename-menu id to-be-renamed/poss name-dup?) (void))
(define/public (syncheck:add-id-set to-be-renamed/poss name-dup?) (define/public (syncheck:add-id-set to-be-renamed/poss name-dup?) (void))
(add-identifier-to-range to-be-renamed/poss name-dup?))
(define/private (make-rename-menu menu an-identifier-location-set)
(define example-lst (set-first (uf-find (identifier-location-set-set an-identifier-location-set))))
(define name-to-offer (send (list-ref example-lst 0) get-text
(list-ref example-lst 1)
(list-ref example-lst 2)))
(new menu-item%
[parent menu]
[label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)]
[callback
(λ (x y)
(let ([frame-parent (find-menu-parent menu)])
(rename-menu-callback frame-parent
name-to-offer
an-identifier-location-set)))]))
(define/public (syncheck:rename-identifier text) (define/public (syncheck:rename-identifier text)
(when arrow-records (define canvas (send text get-canvas))
(define arrow-record (hash-ref arrow-records text #f))
(define (find-ils pos) (define-values (binding-identifiers identifiers-hash)
(define vec-ents (interval-map-ref arrow-record pos null)) (position->matching-identifiers-hash text
(for/or ([x (in-list vec-ents)]) (send text get-start-position)
(and (identifier-location-set? x) (send text get-end-position)))
x))) (unless (null? binding-identifiers)
(define an-identifier-location-set (define name-to-offer (find-name-to-offer binding-identifiers))
(or (find-ils (send text get-start-position)) (rename-menu-callback identifiers-hash
(and (= (send text get-start-position)
(send text get-end-position))
(find-ils (- (send text get-start-position) 1)))))
(when an-identifier-location-set
(define example-lst (set-first (uf-find (identifier-location-set-set an-identifier-location-set))))
(define name-to-offer (send (list-ref example-lst 0) get-text
(list-ref example-lst 1)
(list-ref example-lst 2)))
(define frame-parent
(let ([canvas (send text get-canvas)])
(and canvas
(send canvas get-top-level-window))))
(rename-menu-callback frame-parent
name-to-offer name-to-offer
an-identifier-location-set)))) binding-identifiers
(and canvas (send canvas get-top-level-window)))))
(define/public (syncheck:tack/untack-arrows text) (define/public (syncheck:tack/untack-arrows text)
@ -717,15 +689,14 @@ If the namespace does not, they are colored the unbound color.
(when arrows (when arrows
(tack/untack-callback arrows)))) (tack/untack-callback arrows))))
;; rename-callback : string ;; rename-callback : (non-empty-listof identifier?)
;; (and/c syncheck-text<%> definitions-text<%>)
;; (list source number number)
;; (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 identifiers-hash name-to-offer binding-identifiers parent)
(define name-dup? (identifier-location-set-name-dup? an-identifier-location-set)) (define (name-dup? x)
(for/or ([var-arrow (in-list binding-identifiers)])
((var-arrow-name-dup? var-arrow) x)))
(define new-str (define new-str
(fw:keymap:call/text-keymap-initializer (fw:keymap:call/text-keymap-initializer
(λ () (λ ()
@ -755,29 +726,41 @@ If the namespace does not, they are colored the unbound color.
1))) 1)))
(when do-renaming? (when do-renaming?
(define txts (list this)) (define edit-sequence-txts (list this))
(define positions-to-rename (define per-txt-positions (make-hash))
(remove-duplicates (for ([(k _) (in-hash identifiers-hash)])
(sort (set->list (uf-find (define-values (txt start-pos end-pos) (apply values k))
(identifier-location-set-set (hash-set! per-txt-positions txt
an-identifier-location-set))) (cons (cons start-pos end-pos)
> (hash-ref per-txt-positions txt '()))))
#:key cadr))) (for ([(source-txt start+ends) (in-hash per-txt-positions)])
(when (is-a? source-txt text%)
(define merged-positions (sort-and-merge start+ends))
(begin-edit-sequence) (begin-edit-sequence)
(for ([info (in-list positions-to-rename)]) (for ([start+end (in-list (reverse merged-positions))])
(define source-editor (list-ref info 0)) (define start (car start+end))
(define start (list-ref info 1)) (define end (cdr start+end))
(define end (list-ref info 2)) (unless (memq source-txt edit-sequence-txts)
(when (is-a? source-editor text%) (send source-txt begin-edit-sequence)
(unless (memq source-editor txts) (set! edit-sequence-txts (cons source-txt edit-sequence-txts)))
(send source-editor begin-edit-sequence) (send source-txt delete start end #f)
(set! txts (cons source-editor txts))) (send source-txt insert new-sym start start #f))))
(send source-editor delete start end #f) (for ([txt (in-list edit-sequence-txts)])
(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-name-to-offer : (non-empty-listof identifier?) -> string?
(define/private (find-name-to-offer binding-var-arrows)
(define longest-var-arrow
(car
(sort binding-var-arrows
>
#: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)))
;; 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)
@ -816,11 +799,22 @@ If the namespace does not, they are colored the unbound color.
raw-color)) raw-color))
(add-to-range/key text start fin (make-colored-region color text start fin) #f #f)))) (add-to-range/key text start fin (make-colored-region color text start fin) #f #f))))
;; syncheck:add-arrow : symbol text number number text number number boolean -> void ;; this method is no longer used; see docs for more
;; pre: start-editor, end-editor are embedded in `this' (or are `this')
(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))
;; 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?)
(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
@ -828,7 +822,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)]) actual? level 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)))))
@ -880,32 +874,6 @@ If the namespace does not, they are colored the unbound color.
[else [else
(interval-map-cons*! (interval-map-cons*!
arrow-record start end to-add null)]))) arrow-record start end to-add null)])))
(define/private (add-identifier-to-range text/start/ends name-dup?)
(when arrow-records
(define id-set (apply set text/start/ends))
(define fresh-uf (uf-new id-set))
(define new-il-set (identifier-location-set fresh-uf name-dup?))
(for ([text/start/span (in-list text/start/ends)])
(define arrow-record (get-arrow-record (list-ref text/start/span 0)))
(define start (list-ref text/start/span 1))
(define end (list-ref text/start/span 2))
(interval-map-update*! arrow-record start end
(lambda (curr-val)
(define this-uf-set
(for/or ([thing (in-list curr-val)])
(and (identifier-location-set? thing)
(identifier-location-set-set thing))))
(cond
[this-uf-set
(set! id-set (set-union (uf-find this-uf-set) id-set))
(uf-union! fresh-uf this-uf-set)
(uf-set-canonical! this-uf-set id-set)
curr-val]
[else
(cons new-il-set curr-val)]))
'()))))
(inherit get-top-level-window) (inherit get-top-level-window)
(define/augment (on-change) (define/augment (on-change)
@ -1209,10 +1177,6 @@ If the namespace does not, they are colored the unbound color.
(define var-arrows (filter var-arrow? arrows)) (define var-arrows (filter var-arrow? arrows))
(define add-menus (append (map cdr (filter pair? vec-ents)) (define add-menus (append (map cdr (filter pair? vec-ents))
(filter procedure? vec-ents))) (filter procedure? vec-ents)))
(define identifier-location-set/f
(for/or ([x (in-list vec-ents)])
(and (identifier-location-set? x)
x)))
(unless (null? arrows) (unless (null? arrows)
(add-sep) (add-sep)
(make-object menu-item% (make-object menu-item%
@ -1273,9 +1237,23 @@ If the namespace does not, they are colored the unbound color.
arrow-record arrow-record
start-selection start-selection
end-selection)))) end-selection))))
(for-each (λ (f) (f menu)) add-menus) (for ([f (in-list add-menus)])
(when identifier-location-set/f (f menu))
(make-rename-menu menu identifier-location-set/f))
(define-values (binding-identifiers identifiers-hash)
(position->matching-identifiers-hash text pos (+ pos 1)))
(unless (null? binding-identifiers)
(define name-to-offer (find-name-to-offer binding-identifiers))
(new menu-item%
[parent menu]
[label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)]
[callback
(λ (x y)
(let ([frame-parent (find-menu-parent menu)])
(rename-menu-callback identifiers-hash
name-to-offer
binding-identifiers
frame-parent)))]))
(void)))) (void))))
(define/private (update-tooltip-frame-and-matching-identifiers refreshing?) (define/private (update-tooltip-frame-and-matching-identifiers refreshing?)
@ -1294,15 +1272,16 @@ 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 current-matching-identifiers (make-hash))
(define/private (update-matching-identifiers refreshing?) (define/private (update-matching-identifiers refreshing?)
(define id-set (position->matching-identifier-set cursor-text cursor-pos))
(define clr "GreenYellow") (define clr "GreenYellow")
(define style 'ellipse) (define style 'ellipse)
(unless (equal? current-matching-identifiers id-set)
(define in-edit-sequence '()) (define in-edit-sequence '())
(define (uh/highlight highlight?) (define (un/highlight highlight?)
(for ([lst (in-set current-matching-identifiers)]) (for ([(lst _) (in-hash current-matching-identifiers)])
(define txt (list-ref lst 0)) (define txt (list-ref lst 0))
(define start (list-ref lst 1)) (define start (list-ref lst 1))
(define end (list-ref lst 2)) (define end (list-ref lst 2))
@ -1313,26 +1292,70 @@ If the namespace does not, they are colored the unbound color.
(if highlight? (if highlight?
(send txt highlight-range start end clr #f 'low style) (send txt highlight-range start end clr #f 'low style)
(send txt unhighlight-range start end clr #f 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))))
;; return the set of locations of identifiers that have the (un/highlight #f)
;; same binding information as the identifier at cursor-pos (if any)
(define/private (position->matching-identifier-set cursor-text cursor-pos) (set! current-matching-identifiers
(define arrow-records (fetch-arrow-records cursor-text cursor-pos)) (if (and cursor-text cursor-pos)
(if arrow-records (let-values ([(_binders hash) (position->matching-identifiers-hash
(let ([an-identifier-location-set cursor-text cursor-pos cursor-pos)])
(for/or ([x (in-list arrow-records)]) hash)
(and (identifier-location-set? x) (make-hash)))
x))])
(if an-identifier-location-set (un/highlight #t)
(uf-find (identifier-location-set-set
an-identifier-location-set)) (for ([txt (in-list in-edit-sequence)])
(set))) (send txt end-edit-sequence)))
(set)))
;; 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 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
(for ([arrow (in-list arrs)])
(when (var-arrow? arrow)
(cond
[(and (equal? (var-arrow-start-text arrow) the-text)
(<= (var-arrow-start-pos-left arrow)
the-pos
(var-arrow-start-pos-right arrow)))
;; a binding occurrence => keep it
(set! binding-arrows (cons arrow binding-arrows))]
[else
;; a bound occurrence => find binders
(for ([candidate-binder (in-list (fetch-arrow-records (var-arrow-start-text arrow)
(var-arrow-start-pos-left arrow)))])
(when (var-arrow? 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-right arrow) (var-arrow-start-pos-right candidate-binder)))
(set! binding-arrows (cons candidate-binder binding-arrows)))))])))))
(define identifiers-hash (make-hash))
(define (add-one txt start end)
(hash-set! identifiers-hash (list txt start end) #t))
(for ([binding-arrow (in-list binding-arrows)])
(add-one (var-arrow-start-text binding-arrow)
(var-arrow-start-pos-left binding-arrow)
(var-arrow-start-pos-right binding-arrow))
(for ([pos (in-range (var-arrow-start-pos-left binding-arrow)
(var-arrow-start-pos-right binding-arrow))])
(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)))))))
(values binding-arrows identifiers-hash))
;; 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
@ -1484,49 +1507,41 @@ If the namespace does not, they are colored the unbound color.
(define/public (syncheck:jump-to-next-bound-occurrence text [backwards? #f]) (define/public (syncheck:jump-to-next-bound-occurrence text [backwards? #f])
(jump-to-binding/bound-helper (jump-to-binding/bound-helper
text text
(λ (pos text vec-ents) (λ (start-pos end-pos text vec-ents)
(jump-to-next-callback pos text backwards?)))) (jump-to-next-callback start-pos end-pos text backwards?))))
;; syncheck:jump-to-binding-occurrence : text -> void ;; syncheck:jump-to-binding-occurrence : text -> void
(define/public (syncheck:jump-to-binding-occurrence text) (define/public (syncheck:jump-to-binding-occurrence text)
(jump-to-binding/bound-helper (jump-to-binding/bound-helper
text text
(λ (pos text vec-ents) (λ (start-pos end-pos text vec-ents)
(jump-to-binding-callback vec-ents)))) (jump-to-binding-callback vec-ents))))
(define/private (jump-to-binding/bound-helper text do-jump) (define/private (jump-to-binding/bound-helper text do-jump)
(let ([pos (send text get-start-position)])
(when arrow-records (when arrow-records
(let ([arrow-record (hash-ref arrow-records text #f)]) (define arrow-record (hash-ref arrow-records text #f))
(when arrow-record (when arrow-record
(let ([vec-ents (filter var-arrow? (interval-map-ref arrow-record pos null))]) (define arrows '())
(unless (null? vec-ents) (define start-pos (send text get-start-position))
(do-jump pos text vec-ents)))))))) (define end-pos (send text get-end-position))
(for ([pos (in-range start-pos (+ end-pos 1))])
(set! arrows (append (filter var-arrow? (interval-map-ref arrow-record pos null))
arrows)))
(unless (null? arrows)
(do-jump start-pos end-pos text arrows)))))
;; jump-to-next-callback : num text (listof arrow) 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 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 orig-arrows (define orig-arrows
(sort (set->list (position->matching-identifier-set txt pos)) (sort (hash-map identifiers-hash
(λ (x y) x))
(λ (x y) (if backwards? (λ (x y) (if backwards?
(not (syncheck:compare-bindings x y)) (not (syncheck:compare-bindings x y))
(syncheck:compare-bindings x y))))) (syncheck:compare-bindings x y)))))
(cond (define best (pick-next-arrow orig-arrows backwards? txt start-pos end-pos))
[(null? orig-arrows) (void)] (when best (jump-to best)))
[(null? (cdr orig-arrows)) (jump-to (car orig-arrows))]
[else
(let loop ([arrows orig-arrows])
(cond
[(null? arrows) (jump-to (car orig-arrows))]
[else
(define arrow (car arrows))
(cond
[(and (object=? txt (list-ref arrow 0))
(<= (list-ref arrow 1) pos (list-ref arrow 2)))
(jump-to (if (null? (cdr arrows))
(car orig-arrows)
(cadr arrows)))]
[else (loop (cdr arrows))])]))]))
;; jump-to : (list text number number) -> void ;; jump-to : (list text number number) -> void
(define/public (jump-to to-arrow) (define/public (jump-to to-arrow)
@ -1831,13 +1846,14 @@ If the namespace does not, they are colored the unbound color.
;; using 'defs-text' all the time is wrong in the case of embedded editors, ;; using 'defs-text' all the time is wrong in the case of embedded editors,
;; but they already don't work and we've arranged for them to not appear here .... ;; but they already don't work and we've arranged for them to not appear here ....
(match x (match x
[`#(syncheck:add-arrow ,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) ,actual? ,level ,name-dup-pc ,name-dup-id)
(send defs-text syncheck:add-arrow (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 start-pos-left start-pos-right
defs-text end-pos-left end-pos-right defs-text end-pos-left end-pos-right
actual? level)] actual? level 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)
@ -1853,6 +1869,13 @@ If the namespace does not, they are colored the unbound color.
[`#(syncheck:add-definition-target ,start-pos ,end-pos ,id ,mods) [`#(syncheck:add-definition-target ,start-pos ,end-pos ,id ,mods)
(send defs-text syncheck:add-definition-target defs-text start-pos end-pos id mods)] (send defs-text syncheck:add-definition-target defs-text start-pos end-pos id mods)]
[`#(syncheck:add-id-set ,to-be-renamed/poss ,name-dup-pc ,name-dup-id) [`#(syncheck:add-id-set ,to-be-renamed/poss ,name-dup-pc ,name-dup-id)
(define to-be-renamed/poss/fixed
(for/list ([lst (in-list to-be-renamed/poss)])
(list defs-text (list-ref lst 0) (list-ref lst 1))))
(define name-dup? (build-name-dup? name-dup-pc name-dup-id))
(send defs-text syncheck:add-id-set to-be-renamed/poss/fixed name-dup?)]))
(define/private (build-name-dup? name-dup-pc name-dup-id)
(define other-side-dead? #f) (define other-side-dead? #f)
(define (name-dup? name) (define (name-dup? name)
(cond (cond
@ -1868,10 +1891,7 @@ If the namespace does not, they are colored the unbound color.
(printf "other side died\n") (printf "other side died\n")
(set! other-side-dead? #t) (set! other-side-dead? #t)
#f])])) #f])]))
(define to-be-renamed/poss/fixed name-dup?)
(for/list ([lst (in-list to-be-renamed/poss)])
(list defs-text (list-ref lst 0) (list-ref lst 1))))
(send defs-text syncheck:add-id-set to-be-renamed/poss/fixed name-dup?)]))
(define/augment (enable-evaluation) (define/augment (enable-evaluation)
(send check-syntax-button enable #t) (send check-syntax-button enable #t)
@ -2291,4 +2311,126 @@ If the namespace does not, they are colored the unbound color.
defs-text defs-text
val)))))) val))))))
(define-runtime-path online-comp.rkt "online-comp.rkt") (define-runtime-path online-comp.rkt "online-comp.rkt")
(define (pick-next-arrow orig-arrows backwards? txt start-pos end-pos)
(cond
[(null? orig-arrows) #f]
[(null? (cdr orig-arrows)) (car orig-arrows)]
[else
;; find-overlap : -> (listof arrow)
;; returns a list of arrows starting with the first arrow
;; that overlaps with 'pos' or is beyond 'pos' if there are
;; no overlapping arrows, and continues thru all of the
;; sorted arrows (wrapping back around thru the buffer)
(define (find-overlap)
(let loop ([fst-arrow (car orig-arrows)]
[rst-arrows (cdr orig-arrows)]
[acc '()])
(cond
[(null? rst-arrows) (reverse (cons fst-arrow acc))]
[else
(define snd-arrow (car rst-arrows))
(cond
[(overlaps? fst-arrow)
(append (cons fst-arrow rst-arrows) (reverse acc))]
[(if backwards?
(between? snd-arrow fst-arrow)
(between? fst-arrow snd-arrow))
(append rst-arrows (reverse (cons fst-arrow acc)))]
[else
(loop snd-arrow (cdr rst-arrows) (cons fst-arrow acc))])])))
;; find-first-non-overlap : (listof arrow) -> arrow
;; finds the first arrow in the input list that does not overlap with
;; start-pos/end-pos or returns (car orig-arrows) if all overlap
(define (find-first-non-overlap arrows)
(or (for/or ([arrow (in-list arrows)])
(and (not (overlaps? arrow))
arrow))
(car orig-arrows)))
(define (overlaps? arrow)
(define-values (a-text a-left a-right) (apply values arrow))
(and (equal? a-text txt)
(not (or (end-pos . < . a-left)
(a-right . < . start-pos)))))
(define (between? fst-arrow snd-arrow)
(define-values (fa-text fa-left fa-right) (apply values fst-arrow))
(define-values (sa-text sa-left sa-right) (apply values snd-arrow))
(and (equal? fa-text sa-text)
(overlaps? (list fa-text fa-right sa-left))))
(find-first-non-overlap (find-overlap))]))
(module+ test
(check-equal? (pick-next-arrow '() #t 'txt1 0 1) #f)
(check-equal? (pick-next-arrow '((a 1 2)) #t 'txt1 0 1) '(a 1 2))
(check-equal? (pick-next-arrow '((a 2 3) (a 10 12)) #f 'a 0 1) '(a 2 3))
(check-equal? (pick-next-arrow '((a 1 3) (a 10 12)) #f 'a 0 0) '(a 1 3))
(check-equal? (pick-next-arrow '((a 1 3) (a 10 12)) #f 'a 2 2) '(a 10 12))
(check-equal? (pick-next-arrow '((a 1 3) (a 10 12)) #f 'a 4 4) '(a 10 12))
(check-equal? (pick-next-arrow '((a 1 3) (a 10 12)) #f 'a 11 11) '(a 1 3))
(check-equal? (pick-next-arrow '((a 1 3) (a 10 12)) #f 'a 14 14) '(a 1 3)))
;; sort-and-merge : (listof (cons number number)) -> (listof (cons number number))
;; the result is guaranteed to be non-overlapping ranges,
;; sorted from smallest to largest
(define (sort-and-merge start+ends)
(define sorted-positions (sort start+ends < #:key car))
(let loop ([positions sorted-positions])
(cond
[(null? positions) '()]
[(null? (cdr positions)) positions]
[else
(define fst (car positions))
(define snd (cadr positions))
(cond
[(<= (cdr fst) (car snd)) ;; no overlap
(cons fst (loop (cdr positions)))]
[else
(define merged (cons (car fst) (max (cdr fst) (cdr snd))))
(loop (cons merged (cddr positions)))])])))
(module+ test
(check-equal? (sort-and-merge '()) '())
(check-equal? (sort-and-merge '((1 . 2))) '((1 . 2)))
(check-equal? (sort-and-merge '((1 . 2) (10 . 11))) '((1 . 2) (10 . 11)))
(check-equal? (sort-and-merge '((10 . 11) (1 . 2))) '((1 . 2) (10 . 11)))
(check-equal? (sort-and-merge '((1 . 2) (2 . 3))) '((1 . 2) (2 . 3)))
(check-equal? (sort-and-merge '((2 . 3) (1 . 2))) '((1 . 2) (2 . 3)))
(check-equal? (sort-and-merge '((1 . 3) (2 . 4))) '((1 . 4)))
(check-equal? (sort-and-merge '((2 . 4) (1 . 3))) '((1 . 4)))
(check-equal? (sort-and-merge '((2 . 4) (3 . 11) (1 . 3))) '((1 . 11)))
;; both answers seem fine -- other answers, not so much
(check-not-false (member (sort-and-merge '((1 . 1) (1 . 1)))
(list '((1 . 1) (1 . 1))
'((1 . 1) ))))
(for ([_ (in-range 100)])
(define input
(for/list ([i (in-range 10)])
(define start (random 50))
(cons start (+ start (random 100)))))
(define output (sort-and-merge input))
(define (valid? lst)
(cond
[(null? lst) #t]
[(null? (cdr lst)) #t]
[else
(define fst (car lst))
(define snd (cadr lst))
(and (<= (car fst) (cdr fst) (car snd) (cdr snd))
(valid? (cdr lst)))]))
(check-true
(valid? output)
(format "~s = ~s, but invalid" `(sort-and-merge ',input) `',output))))

View File

@ -10,6 +10,7 @@
syncheck:add-docs-menu syncheck:add-docs-menu
syncheck:add-id-set syncheck:add-id-set
syncheck:add-arrow syncheck:add-arrow
syncheck:add-arrow/name-dup
syncheck:add-tail-arrow syncheck:add-tail-arrow
syncheck:add-mouse-over-status syncheck:add-mouse-over-status
syncheck:add-jump-to-definition syncheck:add-jump-to-definition
@ -55,6 +56,12 @@
end-text end-pos-left end-pos-right end-text end-pos-left end-pos-right
actual? level) actual? level)
(void)) (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?)
(syncheck:add-arrow start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right
actual? level))
(define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos) (void)) (define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos) (void))
(define/public (syncheck:add-mouse-over-status text pos-left pos-right str) (void)) (define/public (syncheck:add-mouse-over-status text pos-left pos-right str) (void))
(define/public (syncheck:add-jump-to-definition text start end id filename submods) (void)) (define/public (syncheck:add-jump-to-definition text start end id filename submods) (void))

View File

@ -15,6 +15,7 @@
syncheck:add-require-open-menu syncheck:add-require-open-menu
syncheck:add-id-set syncheck:add-id-set
syncheck:add-arrow syncheck:add-arrow
syncheck:add-arrow/name-dup
syncheck:add-rename-menu syncheck:add-rename-menu
syncheck:add-tail-arrow syncheck:add-tail-arrow
syncheck:add-mouse-over-status syncheck:add-mouse-over-status

View File

@ -34,10 +34,15 @@
#'(define/override (name args ...) #'(define/override (name args ...)
(add-to-trace (vector 'name wanted-args ...))))])) (add-to-trace (vector 'name wanted-args ...))))]))
(log syncheck:add-arrow (define/override (syncheck:add-arrow/name-dup _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) actual? level 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)))
(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)

View File

@ -537,9 +537,7 @@
(define unused-hash (hash-ref unused/phases level)) (define unused-hash (hash-ref unused/phases level))
(color-unused require-hash unused-hash module-lang-requires)) (color-unused require-hash unused-hash module-lang-requires))
(annotate-counts connections) (annotate-counts connections))
(make-rename-menus (list phase-to-binders phase-to-varrefs phase-to-tops)))
;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] hash-table[syntax -o> #t] -> void ;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] hash-table[syntax -o> #t] -> void
(define (color-unused requires unused module-lang-requires) (define (color-unused requires unused module-lang-requires)
@ -592,7 +590,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? (id-level phase-level x) connections))) (connect-syntaxes x var actual? all-binders (id-level phase-level x) connections)))
(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,7 @@
(connect-syntaxes (if (syntax-source raw-module-path) (connect-syntaxes (if (syntax-source raw-module-path)
raw-module-path raw-module-path
req-stx) req-stx)
var actual? var actual? all-binders
(id-level phase-level var) (id-level phase-level var)
connections)))))))) connections))))))))
@ -722,6 +720,7 @@
(when (pair? val) (when (pair? val)
(define start (car val)) (define start (car val))
(define end (cdr val)) (define end (cdr val))
(define (get-str) (send (list-ref key 0) get-text (list-ref key 1) (list-ref key 2)))
(define (show-starts) (define (show-starts)
(add-mouse-over/loc (list-ref key 0) (list-ref key 1) (list-ref key 2) (add-mouse-over/loc (list-ref key 0) (list-ref key 1) (list-ref key 2)
(cond (cond
@ -765,7 +764,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? level connections) (define (connect-syntaxes from to actual? all-binders level connections)
(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)])
@ -789,10 +788,23 @@
(define end-before (or (hash-ref connections connections-end #f) (cons 0 0))) (define end-before (or (hash-ref connections connections-end #f) (cons 0 0)))
(hash-set! connections connections-start (cons (+ (car start-before) 1) (cdr start-before))) (hash-set! connections connections-start (cons (+ (car start-before) 1) (cdr start-before)))
(hash-set! connections connections-end (cons (car end-before) (+ 1 (cdr end-before))))) (hash-set! connections connections-end (cons (car end-before) (+ 1 (cdr end-before)))))
(send defs-text syncheck:add-arrow (define (name-dup? str)
(define sym (string->symbol str))
(define id1 (datum->syntax from sym))
(define id2 (datum->syntax to sym)) ;; do I need both?
(define ans #f)
(for-each-ids
all-binders
(λ (ids)
(set! ans (or ans
(for/or ([id (in-list ids)])
(or (free-identifier=? id1 id)
(free-identifier=? id2 id)))))))
ans)
(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)))))))) actual? level 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
@ -1064,164 +1076,6 @@
", ")))]))) ", ")))])))
;
;
;
; ;
; ;
;
; ; ;; ;;; ;;;; ;;;; ;;;;; ; ;;;; ;;;;
; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;
; ; ;;; ; ; ;; ; ; ; ; ; ; ; ;;;;
; ;
; ; ;
; ;;;
;; make-rename-menus : (listof phase-to-mapping) -> void
(define (make-rename-menus phase-tos)
;; table : symbol -o> (listof (pair (non-empty-listof identifier?)
;; (non-empty-setof (list ed start fin))))
;; this table maps the names of identifiers to information that tells how to build
;; the rename menus.
;;
;; In the simple case that every identifier in the file has a different
;; name, then each of the symbols in the table will map to a singleton list where the
;; listof identifiers is also a singleton list and each of the '(list ed start fin)'
;; corresponds to the locations of that identifier in the file.
;;
;; In the more common case, there will be multiple, distinct uses of an identifier that
;; are spelled the same way in the file, eg (+ (let ([x 1]) x) (let ([x 2]) x)). In
;; this case, the 'x' entry in the table will point to a list of length two,
;; with each of the corresponding list of identifiers in the pair still being a
;; singleton list.
;;
;; In the bizarro case, some macro will have taken an identifier from its input and
;; put it into two distinct binding locations, eg:
;; (define-syntax-rule (m x) (begin (define x 1) (lambda (x) x)))
;; In this case, there is only one 'x' in the original program, but there are two
;; distinct identifiers (according to free-identifier=?) in the program. To cope
;; with this, the code below recognizes that two distinct identifiers come from the
;; same source location and then puts those two identifiers into the first list into
;; the same 'pair' in the table, unioning the corresponding sets of source locations
(define table (make-hash))
(struct pair (ids locs) #:transparent)
(let ([defs-text (current-annotations)])
(when defs-text
(for ([phase-to-mapping (in-list phase-tos)])
(for ([(level id-set) (in-hash phase-to-mapping)])
(for-each-ids
id-set
(λ (vars)
(for ([var (in-list vars)])
(define ed (find-source-editor var))
(when ed
(define pos (syntax-position var))
(define span (syntax-span var))
(when (and pos span)
(define start (- pos 1))
(define fin (+ start span))
(define loc (list ed start fin))
(define var-sym (syntax-e var))
(define current-pairs (hash-ref table var-sym '()))
(define free-id-matching-pair #f)
(define added-source-loc-sets '())
(define new-pairs
(for/list ([a-pair (in-list current-pairs)])
(define ids (pair-ids a-pair))
(define loc-set (pair-locs a-pair))
(cond
[(ormap (λ (this-id) (free-identifier=? this-id var)) ids)
(define new-pair (pair ids (set-add loc-set loc)))
(set! free-id-matching-pair new-pair)
new-pair]
[(set-member? loc-set loc)
;; here we are in the biazarro case;
;; we found this source location in a set that corresponds to
;; some other identifier. so, we know we need to do some kind of a merger
;; just keep track of the set for now, the merger happens after this loop
(set! added-source-loc-sets (cons a-pair added-source-loc-sets))
a-pair]
[else
a-pair])))
;; first step in updating the table; put the new set in.
(cond
[free-id-matching-pair
(hash-set! table var-sym new-pairs)]
[else
(set! free-id-matching-pair (pair (list var) (set loc)))
(hash-set! table var-sym (cons free-id-matching-pair new-pairs))])
(unless (null? added-source-loc-sets)
;; here we are in the bizarro case; we need to union the sets
;; in the added-source-loc-sets list.
(define pairs-to-merge (cons free-id-matching-pair added-source-loc-sets))
(define removed-sets (filter (λ (x) (not (memq x pairs-to-merge)))
(hash-ref table var-sym)))
(define new-pair (pair (apply append (map pair-ids pairs-to-merge))
(apply set-union (map pair-locs pairs-to-merge))))
(hash-set! table var-sym (cons new-pair removed-sets))))))))))
(hash-for-each
table
(λ (id-as-sym pairs)
(for ([a-pair (in-list pairs)])
(define loc-lst (set->list (pair-locs a-pair)))
(define ids (pair-ids a-pair))
(define (name-dup? new-str)
(and (for/or ([phase-to-map (in-list phase-tos)])
(for/or ([(level id-set) (in-hash phase-to-map)])
(for/or ([id (in-list ids)])
(for/or ([corresponding-id (in-list (or (get-ids id-set id) '()))])
(let ([new-id (datum->syntax corresponding-id (string->symbol new-str))])
(for/or ([phase-to-map (in-list phase-tos)])
(for/or ([(level id-set) (in-hash phase-to-map)])
(get-ids id-set new-id))))))))
#t))
(define max-to-send-at-once (current-max-to-send-at-once))
(let loop ([loc-lst loc-lst]
[len (length loc-lst)])
(cond
[(<= len max-to-send-at-once)
(send defs-text syncheck:add-id-set
loc-lst
name-dup?)]
[else
(send defs-text syncheck:add-id-set
(take loc-lst max-to-send-at-once)
name-dup?)
;; drop one fewer so that we're sure that the
;; sets get unioned properly
(loop (drop loc-lst (- max-to-send-at-once 1))
(- len (- max-to-send-at-once 1)))]))))))))
;; remove-duplicates-stx : (listof syntax[original]) -> (listof syntax[original])
;; removes duplicates, based on the source locations of the identifiers
(define (remove-duplicates-stx ids)
(cond
[(null? ids) null]
[else (let loop ([fst (car ids)]
[rst (cdr ids)])
(cond
[(null? rst) (list fst)]
[else (if (and (eq? (syntax-source fst)
(syntax-source (car rst)))
(= (syntax-position fst)
(syntax-position (car rst))))
(loop fst (cdr rst))
(cons fst (loop (car rst) (cdr rst))))]))]))
; ;
; ;
; ;

View File

@ -650,7 +650,7 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
} }
@defparam[current-max-to-send-at-once m (or/c +inf.0 (and/c exact-integer? (>=/c 2)))]{ @defparam[current-max-to-send-at-once m (or/c +inf.0 (and/c exact-integer? (>=/c 2)))]{
See @xmethod[syncheck-annotations<%> syncheck:add-id-set]. No longer used.
} }
@definterface[syncheck-annotations<%> ()]{ @definterface[syncheck-annotations<%> ()]{
@ -715,23 +715,10 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
exact-nonnegative-integer? exact-nonnegative-integer?
exact-nonnegative-integer?))] exact-nonnegative-integer?))]
[new-name-interferes? (-> symbol boolean?)]) [new-name-interferes? (-> symbol boolean?)])
void?]{ void?]{This method is no longer called by Check Syntax. It is here
Called to indicate that all of the locations in the @racket[all-ids] list for backwards compatibility only. The information it provided
refer to the same identifier. must now be synthesized from the information supplied to
@method[syncheck-annotations<%> syncheck:add-arrow/name-dup].}
The @racket[new-name-interferes?] procedure determines if a potential new name
at one of the corresponding places would interfere with the existing bindings
in the program.
Usually, this method is called with maximal sets in @racket[all-ids], in the
sense that, for a given call, either a source location is in the list, or
the location it does not contain a identifier that refers to one of the ones
in @racket[all-ids]. If, however, @racket[current-max-to-send-at-once] is not
@racket[+inf.0], then this set might not contain all of the source locations
for a given identifier and multiple calls are made. In the case that multiple
calls are made, the intersection of the @racket[all-ids] lists (on those
multiple calls) is non-empty.
}
@defmethod[(syncheck:add-arrow [start-source-obj (not/c #f)] @defmethod[(syncheck:add-arrow [start-source-obj (not/c #f)]
[start-left exact-nonnegative-integer?] [start-left exact-nonnegative-integer?]
@ -742,10 +729,33 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
[actual? boolean?] [actual? boolean?]
[phase-level (or/c exact-nonnegative-integer? #f)]) [phase-level (or/c exact-nonnegative-integer? #f)])
void?]{ void?]{
This function is not called directly anymore by Check Syntax. Instead
@method[syncheck-annotations<%> syncheck:add-arrow/name-dup] is.
This method is invoked by the default implementation of
@racket[_syncheck:add-arrow/name-dup] in
@racket[annotations-mixin].
}
@defmethod[(syncheck:add-arrow/name-dup [start-source-obj (not/c #f)]
[start-left exact-nonnegative-integer?]
[start-right exact-nonnegative-integer?]
[end-source-obj (not/c #f)]
[end-left exact-nonnegative-integer?]
[end-right exact-nonnegative-integer?]
[actual? boolean?]
[phase-level (or/c exact-nonnegative-integer? #f)]
[name-dup? (-> string? boolean?)])
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.
The @racket[phase-level] argument indicates the phase of the binding and the @racket[actual?] argument The @racket[phase-level] argument indicates the phase of the binding and the @racket[actual?] argument
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[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
the time the program was expanded).
} }
@defmethod[(syncheck:add-tail-arrow [from-source-obj (not/c #f)] @defmethod[(syncheck:add-tail-arrow [from-source-obj (not/c #f)]
[from-pos exact-nonnegative-integer?] [from-pos exact-nonnegative-integer?]
@ -797,10 +807,8 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
exact-nonnegative-integer?))] exact-nonnegative-integer?))]
[new-name-interferes? (-> symbol boolean?)]) [new-name-interferes? (-> symbol boolean?)])
void?]{ void?]{
This method is listed only for backwards compatibility. It is not called directly This method is listed only for backwards compatibility. It is not called
by check syntax, but it is called by the default implementation of by Check Syntax anymore.
@method[syncheck-annotations<%> syncheck:add-rename-menu] in
@racket[annotations-mixin].
} }
} }
@ -814,40 +822,33 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
By default: By default:
@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-id-set] @item{the @method[syncheck-annotations<%> syncheck:add-arrow/name-dup] method drops the
manufactures a symbol and then passes that and its arguments to @racket[_name-dup?] argument and calls
@method[syncheck-annotations<%> syncheck:add-rename-menu] @method[syncheck-annotations<%> syncheck:add-arrow]; and}
(this is for backwards compatibility -- the @method[syncheck-annotations<%> syncheck:add-rename-menu]
is not called directly by Check Syntax anymore; the @method[syncheck-annotations<%> syncheck:add-id-set]
calls it instead); 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:
@interaction[#:eval syncheck-example-eval @interaction[#:eval
syncheck-example-eval
(require drracket/check-syntax racket/class) (require drracket/check-syntax racket/class)
(define arrows-collector% (define arrows-collector%
(class (annotations-mixin object%) (class (annotations-mixin object%)
(super-new) (super-new)
(define/override (syncheck:find-source-object stx) (define/override (syncheck:find-source-object stx)
stx) stx)
(define/override (syncheck:add-arrow start-source-obj (define/override (syncheck:add-arrow/name-dup
start-left start-source-obj start-left start-right
start-right end-source-obj end-left end-right
end-source-obj actual? phase-level name-dup?)
end-left
end-right
actual?
phase-level)
(set! arrows (set! arrows
(cons (list start-source-obj end-source-obj) (cons (list start-source-obj end-source-obj)
arrows))) arrows)))
(define arrows '()) (define arrows '())
(define/public (collected-arrows) arrows))) (define/public (get-collected-arrows) arrows)))
(define (arrows form) (define (arrows form)
(define base-namespace (define base-namespace (make-base-namespace))
(make-base-namespace))
(define-values (add-syntax done) (define-values (add-syntax done)
(make-traversal base-namespace #f)) (make-traversal base-namespace #f))
(define collector (new arrows-collector%)) (define collector (new arrows-collector%))
@ -855,7 +856,7 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
[current-namespace base-namespace]) [current-namespace base-namespace])
(add-syntax (expand form)) (add-syntax (expand form))
(done)) (done))
(send collector collected-arrows)) (send collector get-collected-arrows))
(define (make-id name pos orig?) (define (make-id name pos orig?)
(datum->syntax (datum->syntax
#f #f
@ -881,6 +882,7 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
syncheck:add-docs-menu syncheck:add-docs-menu
syncheck:add-rename-menu syncheck:add-rename-menu
syncheck:add-arrow syncheck:add-arrow
syncheck:add-arrow/name-dup
syncheck:add-tail-arrow syncheck:add-tail-arrow
syncheck:add-mouse-over-status syncheck:add-mouse-over-status
syncheck:add-jump-to-definition syncheck:add-jump-to-definition

View File

@ -1074,11 +1074,11 @@
"yxy" "yxy"
"(lambda (yxy) yxy yxy)") "(lambda (yxy) yxy yxy)")
(build-rename-test "(define-syntax-rule (m x) (λ (x) x))(m z)" (build-rename-test "(define-syntax-rule (m x y) (λ (x) x y))(m z z)"
39 43
"z" "z"
"qq" "qq"
"(define-syntax-rule (m x) (λ (x) x))(m qq)") "(define-syntax-rule (m x y) (λ (x) x y))(m qq qq)")
(build-rename-test (string-append (build-rename-test (string-append
"#lang racket/base\n" "#lang racket/base\n"
@ -1294,7 +1294,7 @@
[menu-item [menu-item
menu-item] menu-item]
[else [else
(eprintf "syncheck-test.rkt: rename test ~s didn't find menu item named ~s in ~s" (eprintf "syncheck-test.rkt: rename test ~s didn't find menu item named ~s in ~s\n"
test test
item-name item-name
(map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) (map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label)))

View File

@ -1,3 +1,10 @@
------------------------------
Version 5.3.4
------------------------------
. Check Syntax no longer calls the syncheck:add-id-set method (and
thus neither the syncheck:add-rename-menu method).
------------------------------ ------------------------------
Version 5.3.3 Version 5.3.3
------------------------------ ------------------------------