From 1a619bd047f23cd52b775dde153a435dc5049f01 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 30 Jul 2012 15:02:37 -0500 Subject: [PATCH] add tooltips at the start and end of arrows indicating how many references there are and how many definition sites there are (in check syntax) also: Rackety --- .../drracket/private/syncheck/annotate.rkt | 29 ++- collects/drracket/private/syncheck/gui.rkt | 33 ++- .../drracket/private/syncheck/traversals.rkt | 240 +++++++++++------- .../private/english-string-constants.rkt | 5 + collects/tests/drracket/syncheck-test.rkt | 79 +++++- 5 files changed, 277 insertions(+), 109 deletions(-) diff --git a/collects/drracket/private/syncheck/annotate.rkt b/collects/drracket/private/syncheck/annotate.rkt index 2f4c2b0884..a0f70d0d10 100644 --- a/collects/drracket/private/syncheck/annotate.rkt +++ b/collects/drracket/private/syncheck/annotate.rkt @@ -5,7 +5,8 @@ (provide color color-range find-source-editor find-source-editor/defs - add-mouse-over) + add-mouse-over + add-mouse-over/loc) ;; color : syntax[original] str -> void ;; colors the syntax with style-name's style @@ -28,16 +29,22 @@ ;; registers the range in the editor so that a mouse over ;; this area shows up in the status line. (define (add-mouse-over stx str) - (let* ([source (find-source-editor stx)] - [defs-text (current-annotations)]) - (when (and defs-text - source - (syntax-position stx) - (syntax-span stx)) - (let* ([pos-left (- (syntax-position stx) 1)] - [pos-right (+ pos-left (syntax-span stx))]) - (send defs-text syncheck:add-mouse-over-status - source pos-left pos-right str))))) + (define source (find-source-editor stx)) + (define defs-text (current-annotations)) + (when (and defs-text + source + (syntax-position stx) + (syntax-span stx)) + (define pos-left (- (syntax-position stx) 1)) + (define pos-right (+ pos-left (syntax-span stx))) + (send defs-text syncheck:add-mouse-over-status + source pos-left pos-right str))) + +(define (add-mouse-over/loc source pos-left pos-right str) + (define defs-text (current-annotations)) + (when defs-text + (send defs-text syncheck:add-mouse-over-status + source pos-left pos-right str))) ;; find-source-editor : stx -> editor or false (define (find-source-editor stx) diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index 9b84c0e641..613eacca8e 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -377,8 +377,37 @@ If the namespace does not, they are colored the unbound color. (hash-set! bindings-table key (cons new priors)) #t]))])) - ;; for use in the automatic test suite - (define/public (syncheck:get-bindings-table) bindings-table) + ;; for use in the automatic test suite (both) + (define/public (syncheck:get-bindings-table [tooltips? #f]) + (cond + [tooltips? + (define unsorted + (apply + append + (for/list ([(k interval-map) (in-hash arrow-records)]) + (apply + append + (dict-map + interval-map + (λ (key x) + (for/list ([x (in-list x)] + #:when (tooltip-info? x)) + (list (tooltip-info-pos-left x) + (tooltip-info-pos-right x) + (tooltip-info-msg x))))))))) + (define (compare l1 l2) + (cond + [(equal? (list-ref l1 0) (list-ref l2 0)) + (cond + [(equal? (list-ref l1 2) (list-ref l2 2)) + (string<=? (list-ref l1 2) (list-ref l2 2))] + [else + (< (list-ref l1 1) (list-ref l2 1))])] + [else + (< (list-ref l1 0) (list-ref l2 0))])) + (sort unsorted compare)] + [else + bindings-table])) (define/public (syncheck:sort-bindings-table) diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt index efa0ab3341..865fbf22c7 100644 --- a/collects/drracket/private/syncheck/traversals.rkt +++ b/collects/drracket/private/syncheck/traversals.rkt @@ -449,73 +449,81 @@ module-lang-requires phase-to-requires) - (let ([unused-requires (make-hash)] - [unused-require-for-syntaxes (make-hash)] - [unused-require-for-templates (make-hash)] - [unused-require-for-labels (make-hash)] - [unused/phases (make-hash)]) - - (for ([(level hash) (in-hash phase-to-requires)]) - (define new-hash (make-hash)) - (hash-set! unused/phases level new-hash) - (for ([(k v) (in-hash hash)]) - (hash-set! new-hash k #t))) - - (for ([(level binders) (in-hash phase-to-binders)]) - (for ([vars (in-list (get-idss binders))]) - (for ([var (in-list vars)]) - (define varset (lookup-phase-to-mapping phase-to-varsets level)) - (color-variable var 0 varset) - (document-variable var 0)))) - - (for ([(level varrefs) (in-hash phase-to-varrefs)]) - (define binders (lookup-phase-to-mapping phase-to-binders level)) - (define varsets (lookup-phase-to-mapping phase-to-varsets level)) - (for ([vars (in-list (get-idss varrefs))]) - (for ([var (in-list vars)]) - (color-variable var level varsets) - (document-variable var level) - (connect-identifier var - binders - unused/phases - phase-to-requires - level - user-namespace - user-directory - #t)))) - - (for ([vars (in-list (get-idss templrefs))]) - (for ([var (in-list vars)]) - - ;; build a set of all of the known phases - (define phases (set)) - (for ([phase (in-list (hash-keys phase-to-binders))]) - (set! phases (set-add phases phase))) - (for ([phase (in-list (hash-keys phase-to-requires))]) - (set! phases (set-add phases phase))) - - ;; connect every identifier inside a quote-syntax to each binder at any phase - (for ([phase (in-set phases)]) - (connect-identifier var - (lookup-phase-to-mapping phase-to-binders phase) - unused/phases - phase-to-requires - phase - user-namespace - user-directory - #f)))) - - (for ([(level tops) (in-hash phase-to-tops)]) - (define binders (lookup-phase-to-mapping phase-to-binders level)) - (for ([vars (in-list (get-idss tops))]) - (for ([var (in-list vars)]) - (color/connect-top user-namespace user-directory binders var)))) - - (for ([(level require-hash) (in-hash phase-to-requires)]) - (define unused-hash (hash-ref unused/phases level)) - (color-unused require-hash unused-hash module-lang-requires)) + (define unused-requires (make-hash)) + (define unused-require-for-syntaxes (make-hash)) + (define unused-require-for-templates (make-hash)) + (define unused-require-for-labels (make-hash)) + (define unused/phases (make-hash)) - (make-rename-menus (list phase-to-binders phase-to-varrefs phase-to-tops)))) + ;; hash[(list (list src pos pos) (list src pos pos)) -o> #t ;; indicates if this arrow has been recorded + ;; (list src pos pos) -o> (cons number number)] ;; indicates the number of defs and uses at this spot + (define connections (make-hash)) + + (for ([(level hash) (in-hash phase-to-requires)]) + (define new-hash (make-hash)) + (hash-set! unused/phases level new-hash) + (for ([(k v) (in-hash hash)]) + (hash-set! new-hash k #t))) + + (for ([(level binders) (in-hash phase-to-binders)]) + (for ([vars (in-list (get-idss binders))]) + (for ([var (in-list vars)]) + (define varset (lookup-phase-to-mapping phase-to-varsets level)) + (color-variable var 0 varset) + (document-variable var 0)))) + + (for ([(level varrefs) (in-hash phase-to-varrefs)]) + (define binders (lookup-phase-to-mapping phase-to-binders level)) + (define varsets (lookup-phase-to-mapping phase-to-varsets level)) + (for ([vars (in-list (get-idss varrefs))]) + (for ([var (in-list vars)]) + (color-variable var level varsets) + (document-variable var level) + (connect-identifier var + binders + unused/phases + phase-to-requires + level + user-namespace + user-directory + #t + connections)))) + + (for ([vars (in-list (get-idss templrefs))]) + (for ([var (in-list vars)]) + + ;; build a set of all of the known phases + (define phases (set)) + (for ([phase (in-list (hash-keys phase-to-binders))]) + (set! phases (set-add phases phase))) + (for ([phase (in-list (hash-keys phase-to-requires))]) + (set! phases (set-add phases phase))) + + ;; connect every identifier inside a quote-syntax to each binder at any phase + (for ([phase (in-set phases)]) + (connect-identifier var + (lookup-phase-to-mapping phase-to-binders phase) + unused/phases + phase-to-requires + phase + user-namespace + user-directory + #f + connections)))) + + (for ([(level tops) (in-hash phase-to-tops)]) + (define binders (lookup-phase-to-mapping phase-to-binders level)) + (for ([vars (in-list (get-idss tops))]) + (for ([var (in-list vars)]) + (color/connect-top user-namespace user-directory binders var connections)))) + + (for ([(level require-hash) (in-hash phase-to-requires)]) + (define unused-hash (hash-ref unused/phases level)) + (color-unused require-hash unused-hash module-lang-requires)) + + (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 (define (color-unused requires unused module-lang-requires) @@ -559,14 +567,16 @@ ;; (union #f hash-table) ;; (union identifier-binding identifier-transformer-binding) ;; boolean + ;; connections-table (see its defn) ;; -> void ;; adds the arrows that correspond to binders/bindings (define (connect-identifier var all-binders unused/phases phase-to-requires - phase-level user-namespace user-directory actual?) + phase-level user-namespace user-directory actual? + connections) (let ([binders (get-ids all-binders var)]) (when binders (for ([x (in-list binders)]) - (connect-syntaxes x var actual? (id-level phase-level x)))) + (connect-syntaxes x var actual? (id-level phase-level x) connections))) (when (and unused/phases phase-to-requires) (let ([req-path/pr (get-module-req-path var phase-level)] @@ -599,7 +609,8 @@ (syntax-e var) req-path)) (connect-syntaxes req-stx var actual? - (id-level phase-level var)))) + (id-level phase-level var) + connections))) req-stxes)))))))) (define (id/require-match? var id req-stx) @@ -646,8 +657,8 @@ mod-path)] [else #f])))) - ;; color/connect-top : namespace directory id-set syntax -> void - (define (color/connect-top user-namespace user-directory binders var) + ;; color/connect-top : namespace directory id-set syntax connections[see defn for ctc] -> void + (define (color/connect-top user-namespace user-directory binders var connections) (let ([top-bound? (or (get-ids binders var) (parameterize ([current-namespace user-namespace]) @@ -660,28 +671,72 @@ [else (add-mouse-over var (format "~s is a free variable" (syntax-e var))) (color var free-variable-style-name)]) - (connect-identifier var binders #f #f 0 user-namespace user-directory #t))) + (connect-identifier var binders #f #f 0 user-namespace user-directory #t connections))) + + ;; annotate-counts : connections[see defn] -> void + ;; this function doesn't try to show the number of uses at + ;; a use site, as it is not obvious how to compute that. + ;; in particular, you could think of following arrows from + ;; the use site back to the definition and then counting + ;; the number of arrows originating there, but consider this example: + ;; (define-syntax-rule (m x y z) + ;; (list (let ([y 1]) x x) + ;; (let ([z 1]) x))) + ;; (m w w w) + ;; if you do that here, then which def site do you pick? + ;; and note that picking both of them leads to double counting + ;; it seems possible to have a different datastructure (one that + ;; records the src locs of each 'end' position of each arrow) + ;; to do this, but maybe lets leave that for another day. + (define (annotate-counts connections) + (for ([(key val) (in-hash connections)]) + (when (pair? val) + (define start (car val)) + (define end (cdr val)) + (define (show-starts) + (add-mouse-over/loc (list-ref key 0) (list-ref key 1) (list-ref key 2) + (cond + [(zero? start) + (string-constant cs-zero-varrefs)] + [(= 1 start) + (string-constant cs-one-varref)] + [else + (format (string-constant cs-n-varrefs) start)]))) + (define (show-ends) + (unless (= 1 end) + (add-mouse-over/loc (list-ref key 0) (list-ref key 1) (list-ref key 2) + (format (string-constant cs-binder-count) end)))) + (cond + [(zero? end) ;; assume this is a binder, show uses + (show-starts)] + [(zero? start) ;; assume this is a use, show bindings (usually just one, so do nothing) + (show-ends)] + [else ;; crazyness, show both + (show-starts) + (show-ends)])))) ;; color-variable : syntax phase-level identifier-mapping -> void (define (color-variable var phase-level varsets) - (let* ([b (identifier-binding var phase-level)] - [lexical? - (or (not b) - (eq? b 'lexical) - (and (pair? b) - (let ([path (caddr b)]) - (and (module-path-index? path) - (self-module? path)))))]) - (cond - [(get-ids varsets var) - (add-mouse-over var (string-constant cs-set!d-variable)) - (color var set!d-variable-style-name)] - [lexical? (color var lexically-bound-variable-style-name)] - [(pair? b) (color var imported-variable-style-name)]))) + (define b (identifier-binding var phase-level)) + (define lexical? (is-lexical? b)) + (cond + [(get-ids varsets var) + (add-mouse-over var (string-constant cs-set!d-variable)) + (color var set!d-variable-style-name)] + [lexical? (color var lexically-bound-variable-style-name)] + [(pair? b) (color var imported-variable-style-name)])) - ;; connect-syntaxes : syntax[original] syntax[original] boolean symbol -> void + (define (is-lexical? b) + (or (not b) + (eq? b 'lexical) + (and (pair? b) + (let ([path (caddr b)]) + (and (module-path-index? path) + (self-module? path)))))) + + ;; 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? level) + (define (connect-syntaxes from to actual? level connections) (let ([from-source (find-source-editor from)] [to-source (find-source-editor to)] [defs-text (current-annotations)]) @@ -696,6 +751,15 @@ [to-pos-left (- (syntax-position to) 1)] [to-pos-right (+ to-pos-left (syntax-span to))]) (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)) + (define connections-key (list connections-start connections-end)) + (unless (hash-ref connections connections-key #f) + (hash-set! connections connections-key #t) + (define start-before (or (hash-ref connections connections-start #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-end (cons (car end-before) (+ 1 (cdr end-before))))) (send defs-text syncheck:add-arrow from-source from-pos-left from-pos-right to-source to-pos-left to-pos-right diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index 239c8122de..dfe49e3edb 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -212,6 +212,11 @@ please adhere to these guidelines: (cs-unused-require "unused require") (cs-free-variable "free variable") + (cs-binder-count "~a binding occurrences") + (cs-zero-varrefs "no bound occurrences") + (cs-one-varref "1 bound occurrence") + (cs-n-varrefs "~a bound occurrences") ;; expected to have one ~a formatter that will accept a number + (cs-contract-my-obligation "Contract: this module's obligation") (cs-contract-their-obligation "Contract: clients modules' obligation") (cs-contract-both-obligation "Contract: both this module and client modules' obligation") diff --git a/collects/tests/drracket/syncheck-test.rkt b/collects/tests/drracket/syncheck-test.rkt index bfd718e961..a678c827fa 100644 --- a/collects/tests/drracket/syncheck-test.rkt +++ b/collects/tests/drracket/syncheck-test.rkt @@ -19,14 +19,15 @@ ;; type test = (make-test string ;; (listof str/ann) ;; (listof (cons (list number number) (listof (list number number))))) - (define-struct test (line input expected arrows) #:transparent) + ;; (listof (list number number) (listof string))) + (define-struct test (line input expected arrows tooltips) #:transparent) (define-struct (dir-test test) () #:transparent) (define-struct rename-test (line input pos old-name new-name output) #:transparent) (define build-test/proc - (λ (line input expected [arrow-table '()]) - (make-test line input expected arrow-table))) + (λ (line input expected [arrow-table '()] #:tooltips [tooltips #f]) + (make-test line input expected arrow-table tooltips))) (define-syntax (build-test stx) (syntax-case stx () @@ -44,7 +45,8 @@ (syntax-case stx () [(_ args ...) (with-syntax ([line (syntax-line stx)]) - #'(make-dir-test line args ...))])) + ;; #f is for the tooltip portion of the test, just skip 'em + #'(make-dir-test line args ... #f))])) ;; tests : (listof test) (define tests @@ -70,7 +72,8 @@ (") " default-color) ("x" lexically-bound-variable) (")" default-color)) - (list '((9 10) (12 13)))) + (list '((9 10) (12 13))) + #:tooltips '((9 10 "1 bound occurrence"))) (build-test "(lambda x x)" '(("(" default-color) ("lambda" imported-syntax) @@ -203,7 +206,10 @@ (" " default-color) ("2" constant) ("))" default-color)) - (list '((7 8) (19 20)))) + (list '((7 8) (19 20))) + #:tooltips '((7 8 "1 bound occurrence") + (7 8 "set!’d variable") + (19 20 "set!’d variable"))) (build-test "object%" '(("object%" imported-syntax))) ; used to be lexically-bound-variable @@ -294,7 +300,54 @@ '((23 24) (39 40) (47 48)) '((25 26) (41 42)) '((27 28) (49 50)) - '((57 58) (59 60) (61 62)))) + '((57 58) (59 60) (61 62))) + #:tooltips '((21 22 "1 bound occurrence") + (23 24 "2 bound occurrences") + (25 26 "1 bound occurrence") + (27 28 "1 bound occurrence") + (57 58 "2 bound occurrences"))) + + (build-test "(define-syntax-rule (m x y z) (list (λ y x) (λ z x)))\n(m w w w)" + '(("(" default-color) + ("define-syntax-rule" imported) + (" (" default-color) + ("m" lexically-bound) + (" " default-color) + ("x" lexically-bound) + (" " default-color) + ("y" lexically-bound) + (" " default-color) + ("z" lexically-bound) + (") (list (λ " default-color) + ("y" lexically-bound) + (" " default-color) + ("x" lexically-bound) + (") (λ " default-color) + ("z" lexically-bound) + (" " default-color) + ("x" lexically-bound) + (")))\n(" default-color) + ("m" lexically-bound) + (" " default-color) + ("w" lexically-bound) + (" " default-color) + ("w" lexically-bound) + (" " default-color) + ("w" lexically-bound) + (")" default-color)) + (list '((21 22) (55 56)) + '((23 24) (41 42) (49 50)) + '((25 26) (39 40)) + '((27 28) (47 48)) + '((61 62) (57 58)) + '((59 60) (57 58))) + #:tooltips '((21 22 "1 bound occurrence") + (23 24 "2 bound occurrences") + (25 26 "1 bound occurrence") + (27 28 "1 bound occurrence") + (57 58 "2 binding occurrences") + (59 60 "1 bound occurrence") + (61 62 "1 bound occurrence"))) (build-test "(module m mzscheme)" '(("(" default-color) @@ -1101,6 +1154,7 @@ (let ([input (test-input test)] [expected (test-expected test)] [arrows (test-arrows test)] + [tooltips (test-tooltips test)] [relative (find-relative-path save-dir (collection-path "mzlib"))]) (cond [(dir-test? test) @@ -1123,7 +1177,11 @@ got arrows (queue-callback/res (λ () (send defs syncheck:get-bindings-table))) - input)))] + input)) + (when tooltips + (compare-tooltips (queue-callback/res (λ () (send defs syncheck:get-bindings-table #t))) + tooltips + (test-line test))))] [(rename-test? test) (insert-in-definitions drs (rename-test-input test)) (click-check-syntax-and-check-errors drs test) @@ -1251,6 +1309,11 @@ (eprintf "FAILED: ~s\n expected: ~s\n got: ~s\n" input expected got)]))) + (define (compare-tooltips got expected line) + (unless (equal? got expected) + (eprintf "FAILED TOOLTIPS: line ~s \n expected: ~s\n got: ~s\n" + line expected got))) + ;; get-annotate-output : drscheme-frame -> (listof str/ann) (define (get-annotated-output drs) (queue-callback/res (λ () (get-string/style-desc (send drs get-definitions-text)))))