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

Support 'sub-range-binders property

Browse Source 
With this commit, renaming & the arrows should work for
struct and define-struct
This commit is contained in:
Robby Findler 2013-07-26 15:54:51 -05:00
parent 6195c432f8
commit c091ac4e8d
3 changed files with 220 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

129
pkgs/drracket-pkgs/drracket-test/tests/drracket/syncheck-test.rkt
View File

@ -19,8 +19,9 @@
;; type str/ann = (list (union symbol string) symbol) ;; type str/ann = (list (union symbol string) symbol)
;; type test = (make-test string ;; type test = (make-test string
;; (or/c (-> any (listof str/ann)) -- if proc, then pass in result of setup thunk ;; (or/c (-> any (listof str/ann))
;; (listof str/ann)) ;; (listof str/ann))
;; -- if proc, then pass in result of setup thunk
;; (listof (cons (list number number) (listof (list number number))))) ;; (listof (cons (list number number) (listof (list number number)))))
;; (listof (list number number) (listof string))) ;; (listof (list number number) (listof string)))
;; (-> any) ;; (-> any)
@ -481,7 +482,9 @@
((39 40) (42 43)) ((39 40) (42 43))
((65 66) (71 72)))) ((65 66) (71 72))))
(build-test "(module m mzscheme (define-for-syntax (f x) x) (define (f x) x) f (define-syntax (m stx) (f stx)))" (build-test (string-append
"(module m mzscheme (define-for-syntax (f x) x)"
" (define (f x) x) f (define-syntax (m stx) (f stx)))")
'(("(" default-color) '(("(" default-color)
("module" imported) ("module" imported)
(" m mzscheme (" default-color) (" m mzscheme (" default-color)
@ -688,7 +691,32 @@
(" " default-color) (" " default-color)
("set-s-a!" lexically-bound-variable) ("set-s-a!" lexically-bound-variable)
(")" default-color)) (")" default-color))
(list '((10 18) (20 33)))) (list '((10 18) (20 33))
'((37 38) (43 44) (61 62))
'((34 35) (41 42) (50 51) (52 53) (59 60))))
(build-test "(module m racket/base (struct s (a [b #:mutable])) s-a s-b s s? set-s-b!)"
'(("(" default-color)
("module" imported-syntax)
(" m racket/base (" default-color)
("struct" imported-syntax)
(" " default-color)
("s" lexically-bound-syntax)
(" (a [b #:mutable])) " default-color)
("s-a" lexically-bound-variable)
(" " default-color)
("s-b" lexically-bound-variable)
(" " default-color)
("s" lexically-bound-variable)
(" " default-color)
("s?" lexically-bound-variable)
(" " default-color)
("set-s-b!" lexically-bound-variable)
(")" default-color))
(list '((10 21) (23 29))
'((30 31) (51 52) (55 56) (59 60) (61 62) (68 69))
'((33 34) (53 54))
'((36 37) (57 58) (70 71))))
(build-test "(let l () l l)" (build-test "(let l () l l)"
'(("(" default-color) '(("(" default-color)
@ -753,7 +781,9 @@
'((39 49) (63 70)) '((39 49) (63 70))
'((51 61) (71 76)))) '((51 61) (71 76))))
(build-test "(module m mzscheme (require (only mzlib/list foldr) (only mzlib/list foldl)) foldl foldr)" (build-test (string-append
"(module m mzscheme (require (only mzlib/list foldr)"
" (only mzlib/list foldl)) foldl foldr)")
'(("(" default-color) '(("(" default-color)
("module" imported-syntax) ("module" imported-syntax)
(" m mzscheme (" default-color) (" m mzscheme (" default-color)
@ -858,7 +888,8 @@
(list '((10 18) (20 26) (33 40)) (list '((10 18) (20 26) (33 40))
'((27 28) (61 62)))) '((27 28) (61 62))))
(build-test "(module m mzscheme (require-for-syntax mzscheme) (require-for-template mzscheme) (quote-syntax +))" (build-test (string-append "(module m mzscheme (require-for-syntax mzscheme)"
" (require-for-template mzscheme) (quote-syntax +))")
'(("(" default-color) '(("(" default-color)
("module" imported) ("module" imported)
(" m mzscheme (" default-color) (" m mzscheme (" default-color)
@ -914,21 +945,22 @@
("sv" lexically-bound) ("sv" lexically-bound)
(" #f #f #f #f))))\n\n#reader'reader\n1\n" default-color)) (" #f #f #f #f))))\n\n#reader'reader\n1\n" default-color))
(list '((15 23) (25 32) (58 62) (65 71) (84 104) (106 117) (122 139) (147 157) (205 209)) (list '((15 23) (25 32) (58 62) (65 71) (84 104) (106 117)
(122 139) (147 157) (205 209))
'((77 79) (210 212)) '((77 79) (210 212))
'((73 76) (41 44)))) '((73 76) (41 44))))
(build-dir-test "(module m mzscheme (require \"~a/list.rkt\") foldl foldl)" (build-dir-test "(module m mzscheme (require \"~a\") first first)"
'(("(" default-color) '(("(" default-color)
("module" imported-syntax) ("module" imported-syntax)
(" m mzscheme (" default-color) (" m mzscheme (" default-color)
("require" imported-syntax) ("require" imported-syntax)
(" \"" default-color) (" \"" default-color)
(relative-path default-color) (relative-path default-color)
("/list.rkt\") " default-color) ("\") " default-color)
("foldl" imported-variable) ("first" imported-variable)
(" " default-color) (" " default-color)
("foldl" imported-variable) ("first" imported-variable)
(")" default-color)) (")" default-color))
#f) #f)
@ -948,7 +980,9 @@
("1))" default-color)) ("1))" default-color))
(list '((27 33) (19 26) (36 49) (53 59) (64 66)))) (list '((27 33) (19 26) (36 49) (53 59) (64 66))))
(build-test "#lang racket (begin-for-syntax (require (for-syntax racket)) (define x 1) (begin-for-syntax (define x 2) x))" (build-test (string-append
"#lang racket (begin-for-syntax (require (for-syntax racket))"
" (define x 1) (begin-for-syntax (define x 2) x))")
'(("#lang racket (" default-color) '(("#lang racket (" default-color)
("begin-for-syntax" imported) ("begin-for-syntax" imported)
(" (" default-color) (" (" default-color)
@ -972,31 +1006,32 @@
'((52 58) (93 99)) '((52 58) (93 99))
'((100 101) (105 106)))) '((100 101) (105 106))))
(build-test "#lang racket (provide (contract-out [f (->i ((p? any/c)) (_ (p?) p?))])) (define (f a) 1)" (build-test
'(("#lang racket (" default-color) "#lang racket (provide (contract-out [f (->i ((p? any/c)) (_ (p?) p?))])) (define (f a) 1)"
("provide" imported) '(("#lang racket (" default-color)
(" (contract-out [" default-color) ("provide" imported)
("f" lexically-bound) (" (contract-out [" default-color)
(" (" default-color) ("f" lexically-bound)
("->i" imported) (" (" default-color)
(" ((" default-color) ("->i" imported)
("p?" lexically-bound) (" ((" default-color)
(" " default-color) ("p?" lexically-bound)
("any/c" imported) (" " default-color)
(")) (_ (" default-color) ("any/c" imported)
("p?" lexically-bound) (")) (_ (" default-color)
(") " default-color) ("p?" lexically-bound)
("p?" lexically-bound) (") " default-color)
("))])) (" default-color) ("p?" lexically-bound)
("define" imported) ("))])) (" default-color)
(" (" default-color) ("define" imported)
("f" lexically-bound) (" (" default-color)
(" " default-color) ("f" lexically-bound)
("a" lexically-bound) (" " default-color)
(") 1)" default-color)) ("a" lexically-bound)
(list '((82 83) (37 38)) (") 1)" default-color))
'((46 48) (61 63) (65 67)) (list '((82 83) (37 38))
'((6 12) (14 21) (40 43) (49 54) (74 80)))) '((46 48) (61 63) (65 67))
'((6 12) (14 21) (40 43) (49 54) (74 80))))
(build-test "#lang racket/base\n(define red 1)\n(module+ test red)" (build-test "#lang racket/base\n(define red 1)\n(module+ test red)"
'(("#lang racket/base\n(" default-color) '(("#lang racket/base\n(" default-color)
@ -1176,14 +1211,15 @@
(let-syntax ([b2 (λ (x) (let-syntax ([b2 (λ (x)
(unless (identifier? x) (unless (identifier? x)
(raise-syntax-error 'b2 "only ids")) (raise-syntax-error 'b2 "only ids"))
(datum->syntax x (datum->syntax
'b1 x
(vector (syntax-source x) 'b1
(syntax-line x) (vector (syntax-source x)
(syntax-column x) (syntax-line x)
(syntax-position x) (syntax-column x)
(string-length (symbol->string 'b1))) (syntax-position x)
x))]) (string-length (symbol->string 'b1)))
x))])
. .
rst)))])) rst)))]))
port)) port))
@ -1398,7 +1434,7 @@
[expected (test-expected test)] [expected (test-expected test)]
[arrows (test-arrows test)] [arrows (test-arrows test)]
[tooltips (test-tooltips test)] [tooltips (test-tooltips test)]
[relative (find-relative-path save-dir (collection-path "mzlib"))] [relative (find-relative-path save-dir (collection-file-path "list.rkt" "racket"))]
[setup (test-setup test)] [setup (test-setup test)]
[teardown (test-teardown test)]) [teardown (test-teardown test)])
(define setup-result (setup)) (define setup-result (setup))
@ -1511,7 +1547,8 @@
(cons fst (loop (cdr ids)))))])))) (cons fst (loop (cdr ids)))))]))))
;; compare-arrows : expression ;; compare-arrows : expression
;; (or/c #f (listof (cons (list number-or-proc number-or-proc) (listof (list number-or-proc number-or-proc))))) ;; (or/c #f (listof (cons (list number-or-proc number-or-proc)
;; (listof (list number-or-proc number-or-proc)))))
;; hash-table[(list text number number) -o> (setof (list text number number))] ;; hash-table[(list text number number) -o> (setof (list text number number))]
;; -> void ;; -> void
(define (compare-arrows test-exp raw-expected raw-actual line) (define (compare-arrows test-exp raw-expected raw-actual line)

95
pkgs/drracket-pkgs/drracket/drracket/private/syncheck/traversals.rkt
View File

@ -12,9 +12,12 @@
racket/set racket/set
racket/class racket/class
racket/list racket/list
racket/contract
syntax/boundmap syntax/boundmap
scribble/manual-struct) scribble/manual-struct)
(define-logger check-syntax)
(provide make-traversal (provide make-traversal
current-max-to-send-at-once) current-max-to-send-at-once)
@ -34,8 +37,9 @@
[tl-phase-to-tops (make-hash)] [tl-phase-to-tops (make-hash)]
[tl-binding-inits (make-id-set)] [tl-binding-inits (make-id-set)]
[tl-templrefs (make-id-set)] [tl-templrefs (make-id-set)]
[tl-phase-to-requires (make-hash)]
[tl-module-lang-requires (make-hash)] [tl-module-lang-requires (make-hash)]
[tl-phase-to-requires (make-hash)]
[tl-sub-identifier-binding-directives (make-hash)]
[expanded-expression [expanded-expression
(λ (sexp [ignored void]) (λ (sexp [ignored void])
(parameterize ([current-directory (or user-directory (current-directory))] (parameterize ([current-directory (or user-directory (current-directory))]
@ -56,7 +60,8 @@
[requires (make-hash)] [requires (make-hash)]
[require-for-syntaxes (make-hash)] [require-for-syntaxes (make-hash)]
[require-for-templates (make-hash)] [require-for-templates (make-hash)]
[require-for-labels (make-hash)]) [require-for-labels (make-hash)]
[sub-identifier-binding-directives (make-hash)])
(annotate-basic sexp (annotate-basic sexp
user-namespace user-directory user-namespace user-directory
phase-to-binders phase-to-binders
@ -66,7 +71,8 @@
binding-inits binding-inits
templrefs templrefs
module-lang-requires module-lang-requires
phase-to-requires) phase-to-requires
sub-identifier-binding-directives)
(annotate-variables user-namespace (annotate-variables user-namespace
user-directory user-directory
phase-to-binders phase-to-binders
@ -75,7 +81,8 @@
phase-to-tops phase-to-tops
templrefs templrefs
module-lang-requires module-lang-requires
phase-to-requires) phase-to-requires
sub-identifier-binding-directives)
(annotate-contracts sexp (annotate-contracts sexp
(hash-ref phase-to-binders 0 (λ () (make-id-set))) (hash-ref phase-to-binders 0 (λ () (make-id-set)))
binding-inits))] binding-inits))]
@ -89,7 +96,8 @@
tl-binding-inits tl-binding-inits
tl-templrefs tl-templrefs
tl-module-lang-requires tl-module-lang-requires
tl-phase-to-requires)]))))] tl-phase-to-requires
tl-sub-identifier-binding-directives)]))))]
[expansion-completed [expansion-completed
(λ () (λ ()
(parameterize ([current-directory (or user-directory (current-directory))] (parameterize ([current-directory (or user-directory (current-directory))]
@ -102,7 +110,8 @@
tl-phase-to-tops tl-phase-to-tops
tl-templrefs tl-templrefs
tl-module-lang-requires tl-module-lang-requires
tl-phase-to-requires)))]) tl-phase-to-requires
tl-sub-identifier-binding-directives)))])
(values expanded-expression expansion-completed))) (values expanded-expression expansion-completed)))
@ -124,7 +133,8 @@
binding-inits binding-inits
templrefs templrefs
module-lang-requires module-lang-requires
phase-to-requires) phase-to-requires
sub-identifier-binding-directives)
(let level+tail+mod-loop ([stx-obj stx-obj] (let level+tail+mod-loop ([stx-obj stx-obj]
[level 0] [level 0]
@ -178,7 +188,11 @@
(λ (stx) (λ (stx)
(add-origins stx varrefs level-of-enclosing-module) (add-origins stx varrefs level-of-enclosing-module)
(add-disappeared-bindings stx binders varrefs level-of-enclosing-module) (add-disappeared-bindings stx binders varrefs level-of-enclosing-module)
(add-disappeared-uses stx varrefs level-of-enclosing-module))]) (add-disappeared-uses stx varrefs level-of-enclosing-module)
(add-sub-range-binders stx
sub-identifier-binding-directives
level
level-of-enclosing-module))])
(collect-general-info stx-obj) (collect-general-info stx-obj)
(define (list-loop/tail-last bodies) (define (list-loop/tail-last bodies)
@ -418,6 +432,36 @@
(define (hash-cons! ht k v) (define (hash-cons! ht k v)
(hash-set! ht k (cons v (hash-ref ht k '())))) (hash-set! ht k (cons v (hash-ref ht k '()))))
(define sub-range-binder-prop?
(vector/c #:flat? #t
syntax? exact-nonnegative-integer? exact-nonnegative-integer?
syntax? exact-nonnegative-integer? exact-nonnegative-integer?))
(define (add-sub-range-binders stx
sub-identifier-binding-directives
level
level-of-enclosing-module)
(let loop ([prop (syntax-property stx 'sub-range-binders)])
(cond
[(pair? prop)
(loop (car prop))
(loop (cdr prop))]
[(sub-range-binder-prop? prop)
(define new-entry
(vector (syntax-shift-phase-level (vector-ref prop 0) level-of-enclosing-module)
(vector-ref prop 1)
(vector-ref prop 2)
(syntax-shift-phase-level (vector-ref prop 3) level-of-enclosing-module)
(vector-ref prop 4)
(vector-ref prop 5)))
(hash-set! sub-identifier-binding-directives
level
(cons new-entry
(hash-ref sub-identifier-binding-directives level '())))]
[(vector? prop)
(log-check-syntax-debug
"found a vector in a 'sub-range-binders property that is ill-formed ~s"
prop)])))
;; add-disappeared-bindings : syntax id-set integer -> void ;; add-disappeared-bindings : syntax id-set integer -> void
(define (add-disappeared-bindings stx binders disappaeared-uses level-of-enclosing-module) (define (add-disappeared-bindings stx binders disappaeared-uses level-of-enclosing-module)
(let ([prop (syntax-property stx 'disappeared-binding)]) (let ([prop (syntax-property stx 'disappeared-binding)])
@ -445,6 +489,7 @@
;; annotate-variables : namespace directory string id-set[four of them] ;; annotate-variables : namespace directory string id-set[four of them]
;; (listof syntax) (listof syntax) ;; (listof syntax) (listof syntax)
;; hash[phase -o> sub-identifier-binding-directive]
;; -> void ;; -> void
;; colors in and draws arrows for variables, according to their classifications ;; colors in and draws arrows for variables, according to their classifications
;; in the various id-sets ;; in the various id-sets
@ -456,7 +501,8 @@
phase-to-tops phase-to-tops
templrefs templrefs
module-lang-requires module-lang-requires
phase-to-requires) phase-to-requires
sub-identifier-binding-directives)
(define unused-requires (make-hash)) (define unused-requires (make-hash))
(define unused-require-for-syntaxes (make-hash)) (define unused-require-for-syntaxes (make-hash))
@ -534,7 +580,22 @@
(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)
(for ([(phase-level directives) (in-hash sub-identifier-binding-directives)])
(for ([directive (in-list directives)])
(match-define (vector binding-id to-start to-span new-binding-id from-start from-span)
directive)
(define all-varrefs (lookup-phase-to-mapping phase-to-varrefs phase-level))
(define all-binders (lookup-phase-to-mapping phase-to-binders phase-level))
(define varrefs (get-ids all-varrefs binding-id))
(when varrefs
(for ([varref (in-list varrefs)])
(connect-syntaxes new-binding-id varref #t all-binders
(id-level phase-level new-binding-id)
connections #f
#:from-start from-start #:from-width from-span
#:to-start to-start #:to-width to-span))))))
;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] hash-table[syntax -o> #t] ;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] hash-table[syntax -o> #t]
;; -> void ;; -> void
@ -767,7 +828,11 @@
;; 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 require-arrow?) (define (connect-syntaxes from to actual? all-binders level connections require-arrow?
#:from-start [from-start 0]
#:from-width [from-width (syntax-span from)]
#:to-start [to-start 0]
#:to-width [to-width (syntax-span to)])
(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)])
@ -777,10 +842,10 @@
[pos-to (syntax-position to)] [pos-to (syntax-position to)]
[span-to (syntax-span to)]) [span-to (syntax-span to)])
(when (and pos-from span-from pos-to span-to) (when (and pos-from span-from pos-to span-to)
(let* ([from-pos-left (- (syntax-position from) 1)] (let* ([from-pos-left (+ (syntax-position from) -1 from-start)]
[from-pos-right (+ from-pos-left (syntax-span from))] [from-pos-right (+ from-pos-left from-width)]
[to-pos-left (- (syntax-position to) 1)] [to-pos-left (+ (syntax-position to) -1 to-start)]
[to-pos-right (+ to-pos-left (syntax-span to))]) [to-pos-right (+ to-pos-left to-width)])
(unless (= from-pos-left to-pos-left) (unless (= from-pos-left to-pos-left)
(define connections-start (list from-source from-pos-left from-pos-right)) (define connections-start (list from-source from-pos-left from-pos-right))
(define connections-end (list to-source to-pos-left to-pos-right)) (define connections-end (list to-source to-pos-left to-pos-right))

60
pkgs/drracket-pkgs/drracket/scribblings/tools/tools.scrbl
View File

@ -931,16 +931,17 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to
The bitmap in the Check Syntax button on the DrRacket frame. The bitmap in the Check Syntax button on the DrRacket frame.
} }
@subsection{Disappeared Uses and Bindings} @subsection{Syntax Properties that Check Syntax Looks For}
@section-index["disappeared-use" "disappeared-binding"] @section-index["disappeared-use" "disappeared-binding" "sub-range-binders"]
Check Syntax collects the values of the Check Syntax collects the values of the
@racket[syntax-property]s named @racket[syntax-property]s named
@racket['disappeared-use] and @racket['disappeared-use],
@racket['disappeared-binding] and uses them to add @racket['disappeared-binding], and
@racket['sub-range-binders], and uses them to add
additional arrows to the program text. These properties are additional arrows to the program text. These properties are
intended for use when a macro discards identifiers that, intended for use when a macro discards or manufactures identifiers that,
from the programmers perspective, should be binding each other. from the programmers perspective, should be binding each other.
For example, here is a macro that discards its arguments, but For example, here is a macro that discards its arguments, but
@ -960,7 +961,54 @@ are treated as a binding/bound pair by Check Syntax.
See also @racket[current-recorded-disappeared-uses]. See also @racket[current-recorded-disappeared-uses].
Check Syntax only draws arrows between identifiers that are @racket[syntax-original?] The value of the @racket['sub-range-binders] property is expected
to be a tree of @racket[cons] pairs (in any configuration) whose leaves
are either ignored or are vectors of the shape
@racketblock[(vector/c syntax? exact-nonnegative-integer? exact-nonnegative-integer?
syntax? exact-nonnegative-integer? exact-nonnegative-integer?)].
If the leaf is a vector, the first syntax object is expected to be an identifier whose
bound occurrences should have arrows that point to the syntax object in the fourth
position in the vector. The numbers indicate the starting point and the range inside
the corresponding identifier to consider as the location of the end of the arrow.
Here's an example:
@codeblock{#lang racket/base
(require (for-syntax racket/base))
(define-syntax (define/hyphen stx)
(syntax-case stx ()
[(_ id1 id2 rhs-expr)
(let ()
(define first-part (symbol->string (syntax-e #'id1)))
(define second-part (symbol->string (syntax-e #'id2)))
(define first-len (string-length first-part))
(define second-len (string-length second-part))
(define hyphenated-id
(datum->syntax
#'id1
(string->symbol (string-append first-part "-" second-part))))
(syntax-property
#`(define #,hyphenated-id rhs-expr)
'sub-range-binders
(list
(vector (syntax-local-introduce hyphenated-id)
0 first-len
(syntax-local-introduce #'id1)
0 first-len)
(vector (syntax-local-introduce hyphenated-id)
(+ first-len 1) second-len
(syntax-local-introduce #'id2)
0 second-len))))]))
(define/hyphen big generator
11)
(+ big-generator big-generator)}
After putting this code in the DrRacket window, mouse over the words ``big'' and
``generator'' to see arrows pointing to the individual pieces of the identifier
@racket[_big-generator].
Finally, Check Syntax only draws arrows between identifiers that are @racket[syntax-original?]
or that have the @racket[syntax-property] @racket['original-for-check-syntax] or that have the @racket[syntax-property] @racket['original-for-check-syntax]
set to @racket[#t]. set to @racket[#t].