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

add tooltips at the start and end of arrows indicating how many references

Browse Source 
there are and how many definition sites there are (in check syntax)

also: Rackety
This commit is contained in:
Robby Findler 2012-07-30 15:02:37 -05:00
parent ec41d86fef
commit 1a619bd047
5 changed files with 277 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/drracket/private/syncheck/annotate.rkt
View File

@ -5,7 +5,8 @@
(provide color color-range (provide color color-range
find-source-editor find-source-editor
find-source-editor/defs find-source-editor/defs
add-mouse-over) add-mouse-over
add-mouse-over/loc)
;; color : syntax[original] str -> void ;; color : syntax[original] str -> void
;; colors the syntax with style-name's style ;; colors the syntax with style-name's style
@ -28,16 +29,22 @@
;; registers the range in the editor so that a mouse over ;; registers the range in the editor so that a mouse over
;; this area shows up in the status line. ;; this area shows up in the status line.
(define (add-mouse-over stx str) (define (add-mouse-over stx str)
(let* ([source (find-source-editor stx)] (define source (find-source-editor stx))
[defs-text (current-annotations)]) (define defs-text (current-annotations))
(when (and defs-text (when (and defs-text
source source
(syntax-position stx) (syntax-position stx)
(syntax-span stx)) (syntax-span stx))
(let* ([pos-left (- (syntax-position stx) 1)] (define pos-left (- (syntax-position stx) 1))
[pos-right (+ pos-left (syntax-span stx))]) (define pos-right (+ pos-left (syntax-span stx)))
(send defs-text syncheck:add-mouse-over-status (send defs-text syncheck:add-mouse-over-status
source pos-left pos-right str))))) 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 ;; find-source-editor : stx -> editor or false
(define (find-source-editor stx) (define (find-source-editor stx)

33
collects/drracket/private/syncheck/gui.rkt
View File

@ -377,8 +377,37 @@ If the namespace does not, they are colored the unbound color.
(hash-set! bindings-table key (cons new priors)) (hash-set! bindings-table key (cons new priors))
#t]))])) #t]))]))
;; for use in the automatic test suite ;; for use in the automatic test suite (both)
(define/public (syncheck:get-bindings-table) bindings-table) (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) (define/public (syncheck:sort-bindings-table)

116
collects/drracket/private/syncheck/traversals.rkt
View File

@ -449,11 +449,15 @@
module-lang-requires module-lang-requires
phase-to-requires) phase-to-requires)
(let ([unused-requires (make-hash)] (define unused-requires (make-hash))
[unused-require-for-syntaxes (make-hash)] (define unused-require-for-syntaxes (make-hash))
[unused-require-for-templates (make-hash)] (define unused-require-for-templates (make-hash))
[unused-require-for-labels (make-hash)] (define unused-require-for-labels (make-hash))
[unused/phases (make-hash)]) (define unused/phases (make-hash))
;; 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)]) (for ([(level hash) (in-hash phase-to-requires)])
(define new-hash (make-hash)) (define new-hash (make-hash))
@ -482,7 +486,8 @@
level level
user-namespace user-namespace
user-directory user-directory
#t)))) #t
connections))))
(for ([vars (in-list (get-idss templrefs))]) (for ([vars (in-list (get-idss templrefs))])
(for ([var (in-list vars)]) (for ([var (in-list vars)])
@ -503,19 +508,22 @@
phase phase
user-namespace user-namespace
user-directory user-directory
#f)))) #f
connections))))
(for ([(level tops) (in-hash phase-to-tops)]) (for ([(level tops) (in-hash phase-to-tops)])
(define binders (lookup-phase-to-mapping phase-to-binders level)) (define binders (lookup-phase-to-mapping phase-to-binders level))
(for ([vars (in-list (get-idss tops))]) (for ([vars (in-list (get-idss tops))])
(for ([var (in-list vars)]) (for ([var (in-list vars)])
(color/connect-top user-namespace user-directory binders var)))) (color/connect-top user-namespace user-directory binders var connections))))
(for ([(level require-hash) (in-hash phase-to-requires)]) (for ([(level require-hash) (in-hash phase-to-requires)])
(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))
(make-rename-menus (list phase-to-binders phase-to-varrefs phase-to-tops)))) (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)
@ -559,14 +567,16 @@
;; (union #f hash-table) ;; (union #f hash-table)
;; (union identifier-binding identifier-transformer-binding) ;; (union identifier-binding identifier-transformer-binding)
;; boolean ;; boolean
;; connections-table (see its defn)
;; -> void ;; -> void
;; adds the arrows that correspond to binders/bindings ;; adds the arrows that correspond to binders/bindings
(define (connect-identifier var all-binders unused/phases phase-to-requires (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)]) (let ([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)))) (connect-syntaxes x var actual? (id-level phase-level x) connections)))
(when (and unused/phases phase-to-requires) (when (and unused/phases phase-to-requires)
(let ([req-path/pr (get-module-req-path var phase-level)] (let ([req-path/pr (get-module-req-path var phase-level)]
@ -599,7 +609,8 @@
(syntax-e var) (syntax-e var)
req-path)) req-path))
(connect-syntaxes req-stx var actual? (connect-syntaxes req-stx var actual?
(id-level phase-level var)))) (id-level phase-level var)
connections)))
req-stxes)))))))) req-stxes))))))))
(define (id/require-match? var id req-stx) (define (id/require-match? var id req-stx)
@ -646,8 +657,8 @@
mod-path)] mod-path)]
[else #f])))) [else #f]))))
;; color/connect-top : namespace directory id-set syntax -> void ;; color/connect-top : namespace directory id-set syntax connections[see defn for ctc] -> void
(define (color/connect-top user-namespace user-directory binders var) (define (color/connect-top user-namespace user-directory binders var connections)
(let ([top-bound? (let ([top-bound?
(or (get-ids binders var) (or (get-ids binders var)
(parameterize ([current-namespace user-namespace]) (parameterize ([current-namespace user-namespace])
@ -660,28 +671,72 @@
[else [else
(add-mouse-over var (format "~s is a free variable" (syntax-e var))) (add-mouse-over var (format "~s is a free variable" (syntax-e var)))
(color var free-variable-style-name)]) (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 ;; color-variable : syntax phase-level identifier-mapping -> void
(define (color-variable var phase-level varsets) (define (color-variable var phase-level varsets)
(let* ([b (identifier-binding var phase-level)] (define b (identifier-binding var phase-level))
[lexical? (define lexical? (is-lexical? b))
(or (not b)
(eq? b 'lexical)
(and (pair? b)
(let ([path (caddr b)])
(and (module-path-index? path)
(self-module? path)))))])
(cond (cond
[(get-ids varsets var) [(get-ids varsets var)
(add-mouse-over var (string-constant cs-set!d-variable)) (add-mouse-over var (string-constant cs-set!d-variable))
(color var set!d-variable-style-name)] (color var set!d-variable-style-name)]
[lexical? (color var lexically-bound-variable-style-name)] [lexical? (color var lexically-bound-variable-style-name)]
[(pair? b) (color var imported-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. ;; 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)] (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)])
@ -696,6 +751,15 @@
[to-pos-left (- (syntax-position to) 1)] [to-pos-left (- (syntax-position to) 1)]
[to-pos-right (+ to-pos-left (syntax-span to))]) [to-pos-right (+ to-pos-left (syntax-span to))])
(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-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 (send defs-text syncheck:add-arrow
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

5
collects/string-constants/private/english-string-constants.rkt
View File

@ -212,6 +212,11 @@ please adhere to these guidelines:
(cs-unused-require "unused require") (cs-unused-require "unused require")
(cs-free-variable "free variable") (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-my-obligation "Contract: this module's obligation")
(cs-contract-their-obligation "Contract: clients modules' obligation") (cs-contract-their-obligation "Contract: clients modules' obligation")
(cs-contract-both-obligation "Contract: both this module and client modules' obligation") (cs-contract-both-obligation "Contract: both this module and client modules' obligation")

79
collects/tests/drracket/syncheck-test.rkt
View File

@ -19,14 +19,15 @@
;; type test = (make-test string ;; type test = (make-test string
;; (listof str/ann) ;; (listof str/ann)
;; (listof (cons (list number number) (listof (list number number))))) ;; (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 (dir-test test) () #:transparent)
(define-struct rename-test (line input pos old-name new-name output) #:transparent) (define-struct rename-test (line input pos old-name new-name output) #:transparent)
(define build-test/proc (define build-test/proc
(λ (line input expected [arrow-table '()]) (λ (line input expected [arrow-table '()] #:tooltips [tooltips #f])
(make-test line input expected arrow-table))) (make-test line input expected arrow-table tooltips)))
(define-syntax (build-test stx) (define-syntax (build-test stx)
(syntax-case stx () (syntax-case stx ()
@ -44,7 +45,8 @@
(syntax-case stx () (syntax-case stx ()
[(_ args ...) [(_ args ...)
(with-syntax ([line (syntax-line stx)]) (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) ;; tests : (listof test)
(define tests (define tests
@ -70,7 +72,8 @@
(") " default-color) (") " default-color)
("x" lexically-bound-variable) ("x" lexically-bound-variable)
(")" default-color)) (")" default-color))
(list '((9 10) (12 13)))) (list '((9 10) (12 13)))
#:tooltips '((9 10 "1 bound occurrence")))
(build-test "(lambda x x)" (build-test "(lambda x x)"
'(("(" default-color) '(("(" default-color)
("lambda" imported-syntax) ("lambda" imported-syntax)
@ -203,7 +206,10 @@
(" " default-color) (" " default-color)
("2" constant) ("2" constant)
("))" default-color)) ("))" 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%" (build-test "object%"
'(("object%" imported-syntax))) ; used to be lexically-bound-variable '(("object%" imported-syntax))) ; used to be lexically-bound-variable
@ -294,7 +300,54 @@
'((23 24) (39 40) (47 48)) '((23 24) (39 40) (47 48))
'((25 26) (41 42)) '((25 26) (41 42))
'((27 28) (49 50)) '((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)" (build-test "(module m mzscheme)"
'(("(" default-color) '(("(" default-color)
@ -1101,6 +1154,7 @@
(let ([input (test-input test)] (let ([input (test-input test)]
[expected (test-expected test)] [expected (test-expected test)]
[arrows (test-arrows 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-path "mzlib"))])
(cond (cond
[(dir-test? test) [(dir-test? test)
@ -1123,7 +1177,11 @@
got got
arrows arrows
(queue-callback/res (λ () (send defs syncheck:get-bindings-table))) (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) [(rename-test? test)
(insert-in-definitions drs (rename-test-input test)) (insert-in-definitions drs (rename-test-input test))
(click-check-syntax-and-check-errors drs test) (click-check-syntax-and-check-errors drs test)
@ -1251,6 +1309,11 @@
(eprintf "FAILED: ~s\n expected: ~s\n got: ~s\n" (eprintf "FAILED: ~s\n expected: ~s\n got: ~s\n"
input expected got)]))) 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) ;; get-annotate-output : drscheme-frame -> (listof str/ann)
(define (get-annotated-output drs) (define (get-annotated-output drs)
(queue-callback/res (λ () (get-string/style-desc (send drs get-definitions-text))))) (queue-callback/res (λ () (get-string/style-desc (send drs get-definitions-text)))))