diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index fda75cc127..7e967ebd2f 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -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) diff --git a/collects/drracket/private/syncheck/intf.rkt b/collects/drracket/private/syncheck/intf.rkt index 0ea6ead938..76900917b7 100644 --- a/collects/drracket/private/syncheck/intf.rkt +++ b/collects/drracket/private/syncheck/intf.rkt @@ -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)) diff --git a/collects/drracket/private/syncheck/online-comp.rkt b/collects/drracket/private/syncheck/online-comp.rkt index c45d922888..28d4592e2d 100644 --- a/collects/drracket/private/syncheck/online-comp.rkt +++ b/collects/drracket/private/syncheck/online-comp.rkt @@ -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) diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt index 2eee2c8fc5..a95adb1e11 100644 --- a/collects/drracket/private/syncheck/traversals.rkt +++ b/collects/drracket/private/syncheck/traversals.rkt @@ -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 diff --git a/collects/scribblings/tools/tools.scrbl b/collects/scribblings/tools/tools.scrbl index 87a643f7b0..00cdc9b295 100644 --- a/collects/scribblings/tools/tools.scrbl +++ b/collects/scribblings/tools/tools.scrbl @@ -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)))