From c091ac4e8d3976719c882769402e8ac7cdcb0a8e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 26 Jul 2013 15:54:51 -0500 Subject: [PATCH] Support 'sub-range-binders property With this commit, renaming & the arrows should work for struct and define-struct --- .../tests/drracket/syncheck-test.rkt | 131 +++++++++++------- .../drracket/private/syncheck/traversals.rkt | 99 ++++++++++--- .../drracket/scribblings/tools/tools.scrbl | 60 +++++++- 3 files changed, 220 insertions(+), 70 deletions(-) diff --git a/pkgs/drracket-pkgs/drracket-test/tests/drracket/syncheck-test.rkt b/pkgs/drracket-pkgs/drracket-test/tests/drracket/syncheck-test.rkt index b0d69367ff..a4438af057 100644 --- a/pkgs/drracket-pkgs/drracket-test/tests/drracket/syncheck-test.rkt +++ b/pkgs/drracket-pkgs/drracket-test/tests/drracket/syncheck-test.rkt @@ -19,8 +19,9 @@ ;; type str/ann = (list (union symbol string) symbol) ;; 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)) + ;; -- if proc, then pass in result of setup thunk ;; (listof (cons (list number number) (listof (list number number))))) ;; (listof (list number number) (listof string))) ;; (-> any) @@ -481,7 +482,9 @@ ((39 40) (42 43)) ((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) ("module" imported) (" m mzscheme (" default-color) @@ -688,8 +691,33 @@ (" " default-color) ("set-s-a!" lexically-bound-variable) (")" 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)" '(("(" default-color) ("let" imported-syntax) @@ -753,7 +781,9 @@ '((39 49) (63 70)) '((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) ("module" imported-syntax) (" m mzscheme (" default-color) @@ -858,7 +888,8 @@ (list '((10 18) (20 26) (33 40)) '((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) ("module" imported) (" m mzscheme (" default-color) @@ -914,21 +945,22 @@ ("sv" lexically-bound) (" #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)) '((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) ("module" imported-syntax) (" m mzscheme (" default-color) ("require" imported-syntax) (" \"" default-color) (relative-path default-color) - ("/list.rkt\") " default-color) - ("foldl" imported-variable) + ("\") " default-color) + ("first" imported-variable) (" " default-color) - ("foldl" imported-variable) + ("first" imported-variable) (")" default-color)) #f) @@ -948,7 +980,9 @@ ("1))" default-color)) (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) ("begin-for-syntax" imported) (" (" default-color) @@ -972,31 +1006,32 @@ '((52 58) (93 99)) '((100 101) (105 106)))) - (build-test "#lang racket (provide (contract-out [f (->i ((p? any/c)) (_ (p?) p?))])) (define (f a) 1)" - '(("#lang racket (" default-color) - ("provide" imported) - (" (contract-out [" default-color) - ("f" lexically-bound) - (" (" default-color) - ("->i" imported) - (" ((" default-color) - ("p?" lexically-bound) - (" " default-color) - ("any/c" imported) - (")) (_ (" default-color) - ("p?" lexically-bound) - (") " default-color) - ("p?" lexically-bound) - ("))])) (" default-color) - ("define" imported) - (" (" default-color) - ("f" lexically-bound) - (" " default-color) - ("a" lexically-bound) - (") 1)" default-color)) - (list '((82 83) (37 38)) - '((46 48) (61 63) (65 67)) - '((6 12) (14 21) (40 43) (49 54) (74 80)))) + (build-test + "#lang racket (provide (contract-out [f (->i ((p? any/c)) (_ (p?) p?))])) (define (f a) 1)" + '(("#lang racket (" default-color) + ("provide" imported) + (" (contract-out [" default-color) + ("f" lexically-bound) + (" (" default-color) + ("->i" imported) + (" ((" default-color) + ("p?" lexically-bound) + (" " default-color) + ("any/c" imported) + (")) (_ (" default-color) + ("p?" lexically-bound) + (") " default-color) + ("p?" lexically-bound) + ("))])) (" default-color) + ("define" imported) + (" (" default-color) + ("f" lexically-bound) + (" " default-color) + ("a" lexically-bound) + (") 1)" default-color)) + (list '((82 83) (37 38)) + '((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)" '(("#lang racket/base\n(" default-color) @@ -1176,14 +1211,15 @@ (let-syntax ([b2 (λ (x) (unless (identifier? x) (raise-syntax-error 'b2 "only ids")) - (datum->syntax x - 'b1 - (vector (syntax-source x) - (syntax-line x) - (syntax-column x) - (syntax-position x) - (string-length (symbol->string 'b1))) - x))]) + (datum->syntax + x + 'b1 + (vector (syntax-source x) + (syntax-line x) + (syntax-column x) + (syntax-position x) + (string-length (symbol->string 'b1))) + x))]) . rst)))])) port)) @@ -1398,7 +1434,7 @@ [expected (test-expected test)] [arrows (test-arrows 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)] [teardown (test-teardown test)]) (define setup-result (setup)) @@ -1511,7 +1547,8 @@ (cons fst (loop (cdr ids)))))])))) ;; 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))] ;; -> void (define (compare-arrows test-exp raw-expected raw-actual line) diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/traversals.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/traversals.rkt index a7f2d552e4..88648d7173 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/traversals.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/traversals.rkt @@ -12,9 +12,12 @@ racket/set racket/class racket/list + racket/contract syntax/boundmap scribble/manual-struct) +(define-logger check-syntax) + (provide make-traversal current-max-to-send-at-once) @@ -34,8 +37,9 @@ [tl-phase-to-tops (make-hash)] [tl-binding-inits (make-id-set)] [tl-templrefs (make-id-set)] - [tl-phase-to-requires (make-hash)] [tl-module-lang-requires (make-hash)] + [tl-phase-to-requires (make-hash)] + [tl-sub-identifier-binding-directives (make-hash)] [expanded-expression (λ (sexp [ignored void]) (parameterize ([current-directory (or user-directory (current-directory))] @@ -56,7 +60,8 @@ [requires (make-hash)] [require-for-syntaxes (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 user-namespace user-directory phase-to-binders @@ -66,7 +71,8 @@ binding-inits templrefs module-lang-requires - phase-to-requires) + phase-to-requires + sub-identifier-binding-directives) (annotate-variables user-namespace user-directory phase-to-binders @@ -75,7 +81,8 @@ phase-to-tops templrefs module-lang-requires - phase-to-requires) + phase-to-requires + sub-identifier-binding-directives) (annotate-contracts sexp (hash-ref phase-to-binders 0 (λ () (make-id-set))) binding-inits))] @@ -89,7 +96,8 @@ tl-binding-inits tl-templrefs tl-module-lang-requires - tl-phase-to-requires)]))))] + tl-phase-to-requires + tl-sub-identifier-binding-directives)]))))] [expansion-completed (λ () (parameterize ([current-directory (or user-directory (current-directory))] @@ -102,7 +110,8 @@ tl-phase-to-tops tl-templrefs tl-module-lang-requires - tl-phase-to-requires)))]) + tl-phase-to-requires + tl-sub-identifier-binding-directives)))]) (values expanded-expression expansion-completed))) @@ -124,7 +133,8 @@ binding-inits templrefs module-lang-requires - phase-to-requires) + phase-to-requires + sub-identifier-binding-directives) (let level+tail+mod-loop ([stx-obj stx-obj] [level 0] @@ -178,7 +188,11 @@ (λ (stx) (add-origins stx 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) (define (list-loop/tail-last bodies) @@ -417,7 +431,37 @@ (define (hash-cons! ht k v) (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 (define (add-disappeared-bindings stx binders disappaeared-uses level-of-enclosing-module) (let ([prop (syntax-property stx 'disappeared-binding)]) @@ -445,6 +489,7 @@ ;; annotate-variables : namespace directory string id-set[four of them] ;; (listof syntax) (listof syntax) + ;; hash[phase -o> sub-identifier-binding-directive] ;; -> void ;; colors in and draws arrows for variables, according to their classifications ;; in the various id-sets @@ -456,7 +501,8 @@ phase-to-tops templrefs module-lang-requires - phase-to-requires) + phase-to-requires + sub-identifier-binding-directives) (define unused-requires (make-hash)) (define unused-require-for-syntaxes (make-hash)) @@ -534,7 +580,22 @@ (define unused-hash (hash-ref unused/phases level)) (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] ;; -> void @@ -591,7 +652,7 @@ (when binders (for ([x (in-list binders)]) (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)) (define source-req-path/pr (get-module-req-path var phase-level #:nominal? #f)) @@ -767,7 +828,11 @@ ;; 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 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)] [to-source (find-source-editor to)] [defs-text (current-annotations)]) @@ -777,10 +842,10 @@ [pos-to (syntax-position to)] [span-to (syntax-span to)]) (when (and pos-from span-from pos-to span-to) - (let* ([from-pos-left (- (syntax-position from) 1)] - [from-pos-right (+ from-pos-left (syntax-span from))] - [to-pos-left (- (syntax-position to) 1)] - [to-pos-right (+ to-pos-left (syntax-span to))]) + (let* ([from-pos-left (+ (syntax-position from) -1 from-start)] + [from-pos-right (+ from-pos-left from-width)] + [to-pos-left (+ (syntax-position to) -1 to-start)] + [to-pos-right (+ to-pos-left to-width)]) (unless (= from-pos-left to-pos-left) (define connections-start (list from-source from-pos-left from-pos-right)) (define connections-end (list to-source to-pos-left to-pos-right)) diff --git a/pkgs/drracket-pkgs/drracket/scribblings/tools/tools.scrbl b/pkgs/drracket-pkgs/drracket/scribblings/tools/tools.scrbl index 82ee7ceb94..9c94c6207d 100644 --- a/pkgs/drracket-pkgs/drracket/scribblings/tools/tools.scrbl +++ b/pkgs/drracket-pkgs/drracket/scribblings/tools/tools.scrbl @@ -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. } -@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 @racket[syntax-property]s named -@racket['disappeared-use] and -@racket['disappeared-binding] and uses them to add +@racket['disappeared-use], +@racket['disappeared-binding], and +@racket['sub-range-binders], and uses them to add 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. 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]. -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] set to @racket[#t].