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

change a hash so it doesn't map from syntax objects directly, but

Browse Source 
instead constructs a suitable key
This commit is contained in:
Robby Findler 2014-08-02 06:21:14 -05:00
parent bc5ab79910
commit 4315018ace
1 changed files with 31 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -251,6 +251,13 @@
[else [else
(loop fst) (loop fst)
(body-loop (car bodies) (cdr bodies))])))) (body-loop (car bodies) (cdr bodies))]))))
(define (add-module-lang-require stx)
(define key (list (syntax-source stx)
(syntax-position stx)
(syntax-span stx)))
(hash-set! module-lang-requires key #t))
(syntax-case* stx-obj (#%plain-lambda case-lambda if begin begin0 let-values letrec-values (syntax-case* stx-obj (#%plain-lambda case-lambda if begin begin0 let-values letrec-values
set! quote quote-syntax with-continuation-mark set! quote quote-syntax with-continuation-mark
#%plain-app #%top #%plain-module-begin #%plain-app #%top #%plain-module-begin
@ -381,7 +388,7 @@
[(module m-name lang (#%plain-module-begin bodies ...)) [(module m-name lang (#%plain-module-begin bodies ...))
(begin (begin
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module) (annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
(hash-set! module-lang-requires (syntax lang) #t) (add-module-lang-require (syntax lang))
(annotate-require-open user-namespace user-directory (syntax lang)) (annotate-require-open user-namespace user-directory (syntax lang))
(define module-name (syntax-e #'m-name)) (define module-name (syntax-e #'m-name))
(define sub-requires (define sub-requires
@ -396,7 +403,7 @@
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module) (annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
(define module-name (syntax-e #'m-name)) (define module-name (syntax-e #'m-name))
(when (syntax-e #'lang) (when (syntax-e #'lang)
(hash-set! module-lang-requires (syntax lang) #t) (add-module-lang-require (syntax lang))
(annotate-require-open user-namespace user-directory (syntax lang)) (annotate-require-open user-namespace user-directory (syntax lang))
(define sub-requires (define sub-requires
(hash-ref! phase-to-requires (hash-ref! phase-to-requires
@ -664,11 +671,17 @@
;; 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
(define (color-unused requires unused module-lang-requires) (define (color-unused requires unused module-lang-requires)
(hash-for-each (for ([(k v) (in-hash unused)])
unused (define requires-stxes
(λ (k v) (hash-ref requires k
(for-each (λ (stx) (λ ()
(unless (hash-ref module-lang-requires stx #f) (error 'syncheck/traversals.rkt
"requires doesn't have a mapping for ~s"
k))))
(for ([stx (in-list requires-stxes)])
(unless (hash-ref module-lang-requires (list (syntax-source stx)
(syntax-position stx)
(syntax-span stx)) #f)
(define defs-text (current-annotations)) (define defs-text (current-annotations))
(define source-editor (find-source-editor stx)) (define source-editor (find-source-editor stx))
(when (and defs-text source-editor) (when (and defs-text source-editor)
@ -679,12 +692,7 @@
(define fin (+ start span)) (define fin (+ start span))
(send defs-text syncheck:add-background-color (send defs-text syncheck:add-background-color
source-editor start fin "firebrick"))) source-editor start fin "firebrick")))
(color stx unused-require-style-name))) (color stx unused-require-style-name)))))
(hash-ref requires k
(λ ()
(error 'syncheck/traversals.rkt
"requires doesn't have a mapping for ~s"
k)))))))
;; id-level : integer-or-#f-or-'lexical identifier -> symbol ;; id-level : integer-or-#f-or-'lexical identifier -> symbol
(define (id-level phase-level id) (define (id-level phase-level id)