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

Check syntax: added purple arrows to show "apparent bindings" of

Browse Source 
macro-template identifiers
 --This line, and those below, will be ignored--

M    drscheme/syncheck.ss

svn: r5693
This commit is contained in:
Ryan Culpepper 2007-02-26 21:41:33 +00:00
parent 84c0505899
commit 2a35c47ff7
1 changed files with 160 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

204
collects/drscheme/syncheck.ss
View File

@ -104,7 +104,8 @@ If the namespace does not, they are colored the unbound color.
(define-struct arrow (start-x start-y end-x end-y)) (define-struct arrow (start-x start-y end-x end-y))
(define-struct (var-arrow arrow) (define-struct (var-arrow arrow)
(start-text start-pos-left start-pos-right (start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right)) end-text end-pos-left end-pos-right
actual?))
(define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos)) (define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos))
;; id : symbol -- the nominal-source-id from identifier-binding ;; id : symbol -- the nominal-source-id from identifier-binding
@ -113,6 +114,11 @@ If the namespace does not, they are colored the unbound color.
(define tacked-var-brush (send the-brush-list find-or-create-brush "BLUE" 'solid)) (define tacked-var-brush (send the-brush-list find-or-create-brush "BLUE" 'solid))
(define var-pen (send the-pen-list find-or-create-pen "BLUE" 1 'solid)) (define var-pen (send the-pen-list find-or-create-pen "BLUE" 1 'solid))
(define templ-color (send the-color-database find-color "purple"))
(define templ-pen (send the-pen-list find-or-create-pen templ-color 1 'solid))
(define tacked-templ-brush (send the-brush-list find-or-create-brush templ-color 'solid))
(define tail-pen (send the-pen-list find-or-create-pen "orchid" 1 'solid)) (define tail-pen (send the-pen-list find-or-create-pen "orchid" 1 'solid))
(define tacked-tail-brush (send the-brush-list find-or-create-brush "orchid" 'solid)) (define tacked-tail-brush (send the-brush-list find-or-create-brush "orchid" 'solid))
(define untacked-brush (send the-brush-list find-or-create-brush "WHITE" 'solid)) (define untacked-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
@ -350,13 +356,14 @@ If the namespace does not, they are colored the unbound color.
(when (and (<= 0 start-pos end-pos (last-position))) (when (and (<= 0 start-pos end-pos (last-position)))
(add-to-range/key text start-pos end-pos make-menu key #t))) (add-to-range/key text start-pos end-pos make-menu key #t)))
;; syncheck:add-arrow : symbol text number number text number number -> 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') ;; pre: start-editor, end-editor are embedded in `this' (or are `this')
(define/public (syncheck:add-arrow start-text start-pos-left start-pos-right (define/public (syncheck:add-arrow start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right) end-text end-pos-left end-pos-right actual?)
(let* ([arrow (make-var-arrow #f #f #f #f (let* ([arrow (make-var-arrow #f #f #f #f
start-text start-pos-left start-pos-right start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right)]) end-text end-pos-left end-pos-right
actual?)])
(when (add-to-bindings-table (when (add-to-bindings-table
start-text start-pos-left start-pos-right start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right) end-text end-pos-left end-pos-right)
@ -453,24 +460,42 @@ If the namespace does not, they are colored the unbound color.
(when (and arrow-vectors (not before)) (when (and arrow-vectors (not before))
(let ([draw-arrow2 (let ([draw-arrow2
(λ (arrow) (λ (arrow)
(unless (arrow-start-x arrow) (unless (arrow-start-x arrow)
(update-arrow-poss arrow)) (update-arrow-poss arrow))
(let ([start-x (arrow-start-x arrow)] (let ([start-x (arrow-start-x arrow)]
[start-y (arrow-start-y arrow)] [start-y (arrow-start-y arrow)]
[end-x (arrow-end-x arrow)] [end-x (arrow-end-x arrow)]
[end-y (arrow-end-y arrow)]) [end-y (arrow-end-y arrow)])
(unless (and (= start-x end-x) (unless (and (= start-x end-x)
(= start-y end-y)) (= start-y end-y))
(drscheme:arrow:draw-arrow dc start-x start-y end-x end-y dx dy))))] (drscheme:arrow:draw-arrow dc start-x start-y end-x end-y dx dy)
(when (and (var-arrow? arrow) (not (var-arrow-actual? arrow)))
(let-values ([(fw fh _d _v) (send dc get-text-extent "x")])
(send dc draw-text "?"
(+ end-x dx fw)
(+ end-y dy (- fh))))))))]
[old-brush (send dc get-brush)] [old-brush (send dc get-brush)]
[old-pen (send dc get-pen)]) [old-pen (send dc get-pen)]
[old-font (send dc get-font)]
[old-text-foreground (send dc get-text-foreground)]
[old-text-mode (send dc get-text-mode)])
(send dc set-font
(send the-font-list find-or-create-font
(send old-font get-point-size)
'default
'normal
'bold))
(send dc set-text-foreground templ-color)
(hash-table-for-each tacked-hash-table (hash-table-for-each tacked-hash-table
(λ (arrow v) (λ (arrow v)
(when v (when v
(cond (cond
[(var-arrow? arrow) [(var-arrow? arrow)
(send dc set-pen var-pen) (if (var-arrow-actual? arrow)
(send dc set-brush tacked-var-brush)] (begin (send dc set-pen var-pen)
(send dc set-brush tacked-var-brush))
(begin (send dc set-pen templ-pen)
(send dc set-brush tacked-templ-brush)))]
[(tail-arrow? arrow) [(tail-arrow? arrow)
(send dc set-pen tail-pen) (send dc set-pen tail-pen)
(send dc set-brush tacked-tail-brush)]) (send dc set-brush tacked-tail-brush)])
@ -483,8 +508,11 @@ If the namespace does not, they are colored the unbound color.
(for-each (λ (ele) (for-each (λ (ele)
(cond (cond
[(var-arrow? ele) [(var-arrow? ele)
(send dc set-pen var-pen) (if (var-arrow-actual? ele)
(send dc set-brush untacked-brush) (begin (send dc set-pen var-pen)
(send dc set-brush untacked-brush))
(begin (send dc set-pen templ-pen)
(send dc set-brush untacked-brush)))
(draw-arrow2 ele)] (draw-arrow2 ele)]
[(tail-arrow? ele) [(tail-arrow? ele)
(send dc set-pen tail-pen) (send dc set-pen tail-pen)
@ -492,7 +520,10 @@ If the namespace does not, they are colored the unbound color.
(for-each-tail-arrows draw-arrow2 ele)])) (for-each-tail-arrows draw-arrow2 ele)]))
eles))))) eles)))))
(send dc set-brush old-brush) (send dc set-brush old-brush)
(send dc set-pen old-pen)))) (send dc set-pen old-pen)
(send dc set-font old-font)
(send dc set-text-foreground old-text-foreground)
(send dc set-text-mode old-text-mode))))
;; for-each-tail-arrows : (tail-arrow -> void) tail-arrow -> void ;; for-each-tail-arrows : (tail-arrow -> void) tail-arrow -> void
(define/private (for-each-tail-arrows f tail-arrow) (define/private (for-each-tail-arrows f tail-arrow)
@ -1249,8 +1280,10 @@ If the namespace does not, they are colored the unbound color.
[tl-high-varrefs (make-id-set)] [tl-high-varrefs (make-id-set)]
[tl-low-tops (make-id-set)] [tl-low-tops (make-id-set)]
[tl-high-tops (make-id-set)] [tl-high-tops (make-id-set)]
[tl-templrefs (make-id-set)]
[tl-requires (make-hash-table 'equal)] [tl-requires (make-hash-table 'equal)]
[tl-require-for-syntaxes (make-hash-table 'equal)] [tl-require-for-syntaxes (make-hash-table 'equal)]
[tl-require-for-templates (make-hash-table 'equal)]
[expanded-expression [expanded-expression
(λ (user-namespace user-directory sexp jump-to-id) (λ (user-namespace user-directory sexp jump-to-id)
(parameterize ([current-load-relative-directory user-directory]) (parameterize ([current-load-relative-directory user-directory])
@ -1265,11 +1298,14 @@ If the namespace does not, they are colored the unbound color.
[high-varrefs (make-id-set)] [high-varrefs (make-id-set)]
[low-tops (make-id-set)] [low-tops (make-id-set)]
[high-tops (make-id-set)] [high-tops (make-id-set)]
[templrefs (make-id-set)]
[requires (make-hash-table 'equal)] [requires (make-hash-table 'equal)]
[require-for-syntaxes (make-hash-table 'equal)]) [require-for-syntaxes (make-hash-table 'equal)]
[require-for-templates (make-hash-table 'equal)])
(annotate-basic sexp user-namespace user-directory jump-to-id (annotate-basic sexp user-namespace user-directory jump-to-id
low-binders high-binders varrefs high-varrefs low-tops high-tops low-binders high-binders varrefs high-varrefs low-tops high-tops
requires require-for-syntaxes) templrefs
requires require-for-syntaxes require-for-templates)
(annotate-variables user-namespace (annotate-variables user-namespace
user-directory user-directory
low-binders low-binders
@ -1278,14 +1314,19 @@ If the namespace does not, they are colored the unbound color.
high-varrefs high-varrefs
low-tops low-tops
high-tops high-tops
templrefs
requires requires
require-for-syntaxes))] require-for-syntaxes
require-for-templates))]
[else [else
(annotate-basic sexp user-namespace user-directory jump-to-id (annotate-basic sexp user-namespace user-directory jump-to-id
tl-low-binders tl-high-binders tl-low-binders tl-high-binders
tl-low-varrefs tl-high-varrefs tl-low-varrefs tl-high-varrefs
tl-low-tops tl-high-tops tl-low-tops tl-high-tops
tl-requires tl-require-for-syntaxes)]))))] tl-templrefs
tl-requires
tl-require-for-syntaxes
tl-require-for-templates)]))))]
[expansion-completed [expansion-completed
(λ (user-namespace user-directory) (λ (user-namespace user-directory)
(parameterize ([current-load-relative-directory user-directory]) (parameterize ([current-load-relative-directory user-directory])
@ -1297,8 +1338,10 @@ If the namespace does not, they are colored the unbound color.
tl-high-varrefs tl-high-varrefs
tl-low-tops tl-low-tops
tl-high-tops tl-high-tops
tl-templrefs
tl-requires tl-requires
tl-require-for-syntaxes)))]) tl-require-for-syntaxes
tl-require-for-templates)))])
(values expanded-expression expansion-completed))) (values expanded-expression expansion-completed)))
@ -1310,13 +1353,14 @@ If the namespace does not, they are colored the unbound color.
;; string[directory] ;; string[directory]
;; syntax[id] ;; syntax[id]
;; id-set (six of them) ;; id-set (six of them)
;; hash-table[require-spec -> syntax] (two of them) ;; hash-table[require-spec -> syntax] (three of them)
;; -> void ;; -> void
(define (annotate-basic sexp user-namespace user-directory jump-to-id (define (annotate-basic sexp user-namespace user-directory jump-to-id
low-binders high-binders low-binders high-binders
low-varrefs high-varrefs low-varrefs high-varrefs
low-tops high-tops low-tops high-tops
requires require-for-syntaxes) templrefs
requires require-for-syntaxes require-for-templates)
(let ([tail-ht (make-hash-table)] (let ([tail-ht (make-hash-table)]
[maybe-jump [maybe-jump
(λ (vars) (λ (vars)
@ -1345,7 +1389,7 @@ If the namespace does not, they are colored the unbound color.
quote quote-syntax with-continuation-mark quote quote-syntax with-continuation-mark
#%app #%datum #%top #%plain-module-begin #%app #%datum #%top #%plain-module-begin
define-values define-syntaxes define-values-for-syntax module define-values define-syntaxes define-values-for-syntax module
require require-for-syntax provide) require require-for-syntax require-for-template provide)
(if high-level? module-transformer-identifier=? module-identifier=?) (if high-level? module-transformer-identifier=? module-identifier=?)
[(lambda args bodies ...) [(lambda args bodies ...)
(begin (begin
@ -1435,7 +1479,21 @@ If the namespace does not, they are colored the unbound color.
(annotate-raw-keyword sexp varrefs)] (annotate-raw-keyword sexp varrefs)]
[(quote-syntax datum) [(quote-syntax datum)
;(color-internal-structure (syntax datum) constant-style-name) ;(color-internal-structure (syntax datum) constant-style-name)
(annotate-raw-keyword sexp varrefs)] (annotate-raw-keyword sexp varrefs)
(let loop ([stx #'datum])
(cond [(identifier? stx)
(when (syntax-original? stx)
(add-id templrefs stx))]
[(syntax? stx)
(loop (syntax-e stx))]
[(pair? stx)
(loop (car stx))
(loop (cdr stx))]
[(vector? stx)
(for-each loop (vector->list stx))]
[(box? stx)
(loop (unbox stx))]
[else (void)]))]
[(with-continuation-mark a b c) [(with-continuation-mark a b c)
(begin (begin
(annotate-raw-keyword sexp varrefs) (annotate-raw-keyword sexp varrefs)
@ -1501,6 +1559,13 @@ If the namespace does not, they are colored the unbound color.
(for-each (add-require-spec require-for-syntaxes) (for-each (add-require-spec require-for-syntaxes)
new-specs new-specs
(syntax->list (syntax (require-specs ...)))))] (syntax->list (syntax (require-specs ...)))))]
[(require-for-template require-specs ...)
(let ([new-specs (map trim-require-prefix (syntax->list (syntax (require-specs ...))))])
(annotate-raw-keyword sexp varrefs)
(for-each (annotate-require-open user-namespace user-directory) new-specs)
(for-each (add-require-spec require-for-templates)
new-specs
(syntax->list (syntax (require-specs ...)))))]
; module top level only: ; module top level only:
[(provide provide-specs ...) [(provide provide-specs ...)
@ -1574,6 +1639,7 @@ If the namespace does not, they are colored the unbound color.
(unless (req/tag-used? req/tag) (unless (req/tag-used? req/tag)
(color (req/tag-req-stx req/tag) error-style-name))) (color (req/tag-req-stx req/tag) error-style-name)))
;; annotate-variables : namespace directory string id-set[four of them] (listof syntax) (listof syntax) -> void ;; annotate-variables : namespace directory string id-set[four of them] (listof syntax) (listof syntax) -> 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
@ -1585,18 +1651,29 @@ If the namespace does not, they are colored the unbound color.
high-varrefs high-varrefs
low-tops low-tops
high-tops high-tops
templrefs
requires requires
require-for-syntaxes) require-for-syntaxes
require-for-templates)
(let ([rename-ht (let ([rename-ht
;; hash-table[(list source number number) -> (listof syntax)] ;; hash-table[(list source number number) -> (listof syntax)]
(make-hash-table 'equal)] (make-hash-table 'equal)]
[unused-requires (make-hash-table 'equal)] [unused-requires (make-hash-table 'equal)]
[unused-require-for-syntaxes (make-hash-table 'equal)] [unused-require-for-syntaxes (make-hash-table 'equal)]
[unused-require-for-templates (make-hash-table 'equal)]
;; there is no define-for-template form, thus no for-template binders
[template-binders (make-id-set)]
[id-sets (list low-binders high-binders low-varrefs high-varrefs low-tops high-tops)]) [id-sets (list low-binders high-binders low-varrefs high-varrefs low-tops high-tops)])
(hash-table-for-each requires (λ (k v) (hash-table-put! unused-requires k #t))) (hash-table-for-each requires
(hash-table-for-each require-for-syntaxes (λ (k v) (hash-table-put! unused-require-for-syntaxes k #t))) (λ (k v) (hash-table-put! unused-requires k #t)))
(hash-table-for-each require-for-syntaxes
(λ (k v) (hash-table-put! unused-require-for-syntaxes k #t)))
(hash-table-for-each require-for-templates
(lambda (k v) (hash-table-put! unused-require-for-templates k #t)))
(for-each (λ (vars) (for-each (λ (vars)
(for-each (λ (var) (for-each (λ (var)
@ -1617,7 +1694,8 @@ If the namespace does not, they are colored the unbound color.
requires requires
identifier-binding identifier-binding
user-namespace user-namespace
user-directory)) user-directory
#t))
vars)) vars))
(get-idss low-varrefs)) (get-idss low-varrefs))
@ -1631,10 +1709,44 @@ If the namespace does not, they are colored the unbound color.
require-for-syntaxes require-for-syntaxes
identifier-transformer-binding identifier-transformer-binding
user-namespace user-namespace
user-directory)) user-directory
#t))
vars)) vars))
(get-idss high-varrefs)) (get-idss high-varrefs))
(for-each (lambda (vars) (for-each
(lambda (var)
;; no color variable
(connect-identifier var
rename-ht
low-binders
unused-requires
requires
identifier-binding
user-namespace
user-directory
#f)
(connect-identifier var
rename-ht
high-binders
unused-require-for-syntaxes
require-for-syntaxes
identifier-transformer-binding
user-namespace
user-directory
#f)
(connect-identifier var
rename-ht
template-binders ;; dummy; always empty
unused-require-for-templates
require-for-templates
identifier-template-binding
user-namespace
user-directory
#f))
vars))
(get-idss templrefs))
(for-each (for-each
(λ (vars) (λ (vars)
(for-each (for-each
@ -1651,6 +1763,7 @@ If the namespace does not, they are colored the unbound color.
vars)) vars))
(get-idss high-tops)) (get-idss high-tops))
(color-unused require-for-templates unused-require-for-templates)
(color-unused require-for-syntaxes unused-require-for-syntaxes) (color-unused require-for-syntaxes unused-require-for-syntaxes)
(color-unused requires unused-requires) (color-unused requires unused-requires)
(hash-table-for-each rename-ht (lambda (k stxs) (make-rename-menu stxs id-sets))))) (hash-table-for-each rename-ht (lambda (k stxs) (make-rename-menu stxs id-sets)))))
@ -1678,11 +1791,12 @@ If the namespace does not, they are colored the unbound color.
;; (listof id-set) ;; (listof id-set)
;; namespace ;; namespace
;; directory ;; directory
;; boolean
;; -> void ;; -> void
;; adds arrows and rename menus for binders/bindings ;; adds arrows and rename menus for binders/bindings
(define (connect-identifier var rename-ht all-binders unused requires get-binding user-namespace user-directory) (define (connect-identifier var rename-ht all-binders unused requires get-binding user-namespace user-directory actual?)
(connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory) (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?)
(when (get-ids all-binders var) (when (and actual? (get-ids all-binders var))
(record-renamable-var rename-ht var))) (record-renamable-var rename-ht var)))
;; connect-identifier/arrow : syntax ;; connect-identifier/arrow : syntax
@ -1690,14 +1804,15 @@ If the namespace does not, they are colored the unbound color.
;; (union #f hash-table) ;; (union #f hash-table)
;; (union #f hash-table) ;; (union #f hash-table)
;; (union identifier-binding identifier-transformer-binding) ;; (union identifier-binding identifier-transformer-binding)
;; boolean
;; -> void ;; -> void
;; adds the arrows that correspond to binders/bindings ;; adds the arrows that correspond to binders/bindings
(define (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory) (define (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?)
(let ([binders (get-ids all-binders var)]) (let ([binders (get-ids all-binders var)])
(when binders (when binders
(for-each (λ (x) (for-each (λ (x)
(when (syntax-original? x) (when (syntax-original? x)
(connect-syntaxes x var))) (connect-syntaxes x var actual?)))
binders)) binders))
(when (and unused requires) (when (and unused requires)
@ -1720,7 +1835,7 @@ If the namespace does not, they are colored the unbound color.
(add-mouse-over var (format (string-constant cs-mouse-over-import) (add-mouse-over var (format (string-constant cs-mouse-over-import)
(syntax-e var) (syntax-e var)
req-path)) req-path))
(connect-syntaxes req-stx var))) (connect-syntaxes req-stx var actual?)))
req-stxes)))))))) req-stxes))))))))
(define (id/require-match? var id req-stx) (define (id/require-match? var id req-stx)
@ -1766,7 +1881,7 @@ If the namespace does not, they are colored the unbound color.
(if top-bound? (if top-bound?
(color var lexically-bound-variable-style-name) (color var lexically-bound-variable-style-name)
(color var error-style-name)) (color var error-style-name))
(connect-identifier var rename-ht binders #f #f identifier-binding user-namespace user-directory))) (connect-identifier var rename-ht binders #f #f identifier-binding user-namespace user-directory #t)))
;; color-variable : syntax (union identifier-binding identifier-transformer-binding) -> void ;; color-variable : syntax (union identifier-binding identifier-transformer-binding) -> void
(define (color-variable var get-binding) (define (color-variable var get-binding)
@ -1792,9 +1907,9 @@ If the namespace does not, they are colored the unbound color.
[prev (hash-table-get ht key (λ () null))]) [prev (hash-table-get ht key (λ () null))])
(hash-table-put! ht key (cons var prev))))) (hash-table-put! ht key (cons var prev)))))
;; connect-syntaxes : syntax[original] syntax[original] -> void ;; connect-syntaxes : syntax[original] syntax[original] boolean -> 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) (define (connect-syntaxes from to actual?)
(let* ([from-source (syntax-source from)] (let* ([from-source (syntax-source from)]
[to-source (syntax-source to)]) [to-source (syntax-source to)])
(when (and (is-a? from-source text%) (when (and (is-a? from-source text%)
@ -1816,7 +1931,8 @@ If the namespace does not, they are colored the unbound color.
(unless (= from-pos-left to-pos-left) (unless (= from-pos-left to-pos-left)
(send from-syncheck-text syncheck:add-arrow (send from-syncheck-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
actual?))))))))))
;; add-mouse-over : syntax[original] string -> void ;; add-mouse-over : syntax[original] string -> void
;; registers the range in the editor so that a mouse over ;; registers the range in the editor so that a mouse over