1220 lines
59 KiB
Racket
1220 lines
59 KiB
Racket
#lang racket/base
|
|
|
|
(require "colors.rkt"
|
|
"intf.rkt"
|
|
"local-member-names.rkt"
|
|
"annotate.rkt"
|
|
"contract-traversal.rkt"
|
|
"xref.rkt"
|
|
string-constants
|
|
racket/unit
|
|
racket/match
|
|
racket/set
|
|
racket/class
|
|
racket/list
|
|
syntax/boundmap
|
|
framework/preferences
|
|
scribble/manual-struct)
|
|
|
|
(provide make-traversal)
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ;
|
|
; ;
|
|
; ; ; ;
|
|
; ;;; ; ; ; ;; ;;;; ;;; ; ; ;;;; ; ; ;;; ; ; ;;; ; ; ;;; ;;; ; ;;;
|
|
; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ;
|
|
; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;;
|
|
; ;; ; ; ; ; ; ;;;; ; ; ; ;;;; ; ; ;;;;;; ; ;; ;;;; ; ;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;; ; ; ; ;; ;;;;; ; ; ;; ; ;;;;; ; ;;;; ; ;;; ;;;;; ; ;;;
|
|
; ;
|
|
; ;
|
|
; ;
|
|
|
|
|
|
|
|
;; make-traversal : namespace string[directory] -> (values (syntax (union #f syntax) -> void)
|
|
;; (-> void))
|
|
;; returns a pair of functions that close over some state that
|
|
;; represents the top-level of a single program. The first value
|
|
;; is called once for each top-level expression and the second
|
|
;; value is called once, after all expansion is complete.
|
|
(define (make-traversal user-namespace user-directory)
|
|
(let* ([tl-phase-to-binders (make-hash)]
|
|
[tl-phase-to-varrefs (make-hash)]
|
|
[tl-phase-to-varsets (make-hash)]
|
|
[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)]
|
|
[expanded-expression
|
|
(λ (sexp [visit-id void])
|
|
(parameterize ([current-directory (or user-directory (current-directory))]
|
|
[current-load-relative-directory user-directory])
|
|
(let ([is-module? (syntax-case sexp (module)
|
|
[(module . rest) #t]
|
|
[else #f])])
|
|
(cond
|
|
[is-module?
|
|
(let ([phase-to-binders (make-hash)]
|
|
[phase-to-varrefs (make-hash)]
|
|
[phase-to-varsets (make-hash)]
|
|
[phase-to-tops (make-hash)]
|
|
[phase-to-requires (make-hash)]
|
|
[binding-inits (make-id-set)]
|
|
[templrefs (make-id-set)]
|
|
[module-lang-requires (make-hash)]
|
|
[requires (make-hash)]
|
|
[require-for-syntaxes (make-hash)]
|
|
[require-for-templates (make-hash)]
|
|
[require-for-labels (make-hash)])
|
|
(annotate-basic sexp
|
|
user-namespace user-directory visit-id
|
|
phase-to-binders
|
|
phase-to-varrefs
|
|
phase-to-varsets
|
|
phase-to-tops
|
|
binding-inits
|
|
templrefs
|
|
module-lang-requires
|
|
phase-to-requires)
|
|
(annotate-variables user-namespace
|
|
user-directory
|
|
phase-to-binders
|
|
phase-to-varrefs
|
|
phase-to-varsets
|
|
phase-to-tops
|
|
templrefs
|
|
module-lang-requires
|
|
phase-to-requires)
|
|
(annotate-contracts sexp
|
|
(hash-ref phase-to-binders 0 (λ () (make-id-set)))
|
|
binding-inits))]
|
|
[else
|
|
(annotate-basic sexp
|
|
user-namespace user-directory visit-id
|
|
tl-phase-to-binders
|
|
tl-phase-to-varrefs
|
|
tl-phase-to-varsets
|
|
tl-phase-to-tops
|
|
tl-binding-inits
|
|
tl-templrefs
|
|
tl-module-lang-requires
|
|
tl-phase-to-requires)]))))]
|
|
[expansion-completed
|
|
(λ ()
|
|
(parameterize ([current-directory (or user-directory (current-directory))]
|
|
[current-load-relative-directory user-directory])
|
|
(annotate-variables user-namespace
|
|
user-directory
|
|
tl-phase-to-binders
|
|
tl-phase-to-varrefs
|
|
tl-phase-to-varsets
|
|
tl-phase-to-tops
|
|
tl-templrefs
|
|
tl-module-lang-requires
|
|
tl-phase-to-requires)))])
|
|
(values expanded-expression expansion-completed)))
|
|
|
|
|
|
;; type req/tag = (make-req/tag syntax sexp boolean)
|
|
(define-struct req/tag (req-stx req-sexp used?))
|
|
|
|
;; annotate-basic : syntax
|
|
;; namespace
|
|
;; string[directory]
|
|
;; syntax[id]
|
|
;; id-set (8 of them)
|
|
;; hash-table[require-spec -> syntax] (three of them)
|
|
;; -> void
|
|
(define (annotate-basic stx-obj
|
|
user-namespace user-directory visit-id
|
|
phase-to-binders
|
|
phase-to-varrefs
|
|
phase-to-varsets
|
|
phase-to-tops
|
|
binding-inits
|
|
templrefs
|
|
module-lang-requires
|
|
phase-to-requires)
|
|
|
|
(let ([maybe-jump (λ (vars) (visit-id vars))])
|
|
(let level+tail-loop ([stx-obj stx-obj]
|
|
[level 0]
|
|
[tail-parent-src #f]
|
|
[tail-parent-pos #f])
|
|
(define-values (next-tail-parent-src next-tail-parent-pos)
|
|
(let ([child-src (find-source-editor stx-obj)]
|
|
[child-pos (syntax-position stx-obj)]
|
|
[defs-text (current-annotations)])
|
|
(cond
|
|
[(and child-src child-pos defs-text)
|
|
(when (and tail-parent-src tail-parent-pos)
|
|
(unless (and (eq? tail-parent-src child-src)
|
|
(equal? tail-parent-pos child-pos))
|
|
(send defs-text syncheck:add-tail-arrow
|
|
tail-parent-src (- tail-parent-pos 1)
|
|
child-src (- child-pos 1))))
|
|
(values child-src child-pos)]
|
|
[else
|
|
(values tail-parent-src tail-parent-pos)])))
|
|
(let* ([level-loop (λ (sexp level) (level+tail-loop sexp level #f #f))]
|
|
[tail-loop (λ (sexp) (level+tail-loop sexp level next-tail-parent-src next-tail-parent-pos))]
|
|
[loop (λ (sexp) (level+tail-loop sexp level #f #f))]
|
|
[varrefs (lookup-phase-to-mapping phase-to-varrefs level)]
|
|
[varsets (lookup-phase-to-mapping phase-to-varsets level)]
|
|
[binders (lookup-phase-to-mapping phase-to-binders level)]
|
|
[tops (lookup-phase-to-mapping phase-to-tops level)]
|
|
[requires (hash-ref! phase-to-requires level (λ () (make-hash)))]
|
|
[collect-general-info
|
|
(λ (stx)
|
|
(add-origins stx varrefs)
|
|
(add-disappeared-bindings stx binders varrefs)
|
|
(add-disappeared-uses stx varrefs))])
|
|
(collect-general-info stx-obj)
|
|
|
|
(define (list-loop/tail-last bodies)
|
|
(unless (null? bodies)
|
|
(let body-loop ([fst (car bodies)]
|
|
[bodies (cdr bodies)])
|
|
(cond
|
|
[(null? bodies)
|
|
(tail-loop fst)]
|
|
[else
|
|
(loop fst)
|
|
(body-loop (car bodies) (cdr bodies))]))))
|
|
|
|
(syntax-case* stx-obj (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set!
|
|
quote quote-syntax with-continuation-mark
|
|
#%plain-app #%top #%plain-module-begin
|
|
define-values define-syntaxes begin-for-syntax
|
|
module module*
|
|
#%require #%provide #%expression)
|
|
(λ (x y) (free-identifier=? x y level 0))
|
|
[(#%plain-lambda args bodies ...)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(add-binders (syntax args) binders #f #f)
|
|
(list-loop/tail-last (syntax->list (syntax (bodies ...)))))]
|
|
[(case-lambda [argss bodiess ...]...)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(for-each
|
|
(λ (args bodies)
|
|
(add-binders args binders #f #f)
|
|
(list-loop/tail-last (syntax->list bodies)))
|
|
(syntax->list (syntax (argss ...)))
|
|
(syntax->list (syntax ((bodiess ...) ...)))))]
|
|
[(if test then else)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(loop (syntax test))
|
|
(tail-loop (syntax then))
|
|
(tail-loop (syntax else)))]
|
|
[(begin bodies ...)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(list-loop/tail-last (syntax->list (syntax (bodies ...)))))]
|
|
|
|
;; treat a single body expression specially, since this has
|
|
;; different tail behavior.
|
|
[(begin0 body)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(tail-loop (syntax body)))]
|
|
|
|
[(begin0 bodies ...)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(for-each loop (syntax->list (syntax (bodies ...)))))]
|
|
|
|
[(let-values (bindings ...) bs ...)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(for-each collect-general-info (syntax->list (syntax (bindings ...))))
|
|
(with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))])
|
|
(for-each (λ (x es) (add-binders x binders binding-inits es))
|
|
(syntax->list (syntax ((xss ...) ...)))
|
|
(syntax->list (syntax (es ...))))
|
|
(for-each loop (syntax->list (syntax (es ...))))
|
|
(list-loop/tail-last (syntax->list (syntax (bs ...))))))]
|
|
[(letrec-values (bindings ...) bs ...)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(for-each collect-general-info (syntax->list (syntax (bindings ...))))
|
|
(with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))])
|
|
(for-each (λ (x es) (add-binders x binders binding-inits es))
|
|
(syntax->list (syntax ((xss ...) ...)))
|
|
(syntax->list (syntax (es ...))))
|
|
(for-each loop (syntax->list (syntax (es ...))))
|
|
(list-loop/tail-last (syntax->list (syntax (bs ...))))))]
|
|
[(set! var e)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
|
|
;; tops are used here because a binding free use of a set!'d variable
|
|
;; is treated just the same as (#%top . x).
|
|
(add-id varsets (syntax var))
|
|
(if (identifier-binding (syntax var) 0)
|
|
(add-id varrefs (syntax var))
|
|
(add-id tops (syntax var)))
|
|
|
|
(loop (syntax e)))]
|
|
[(quote datum)
|
|
(annotate-raw-keyword stx-obj varrefs)]
|
|
[(quote-syntax datum)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(let loop ([stx #'datum])
|
|
(cond [(identifier? 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)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(loop (syntax a))
|
|
(loop (syntax b))
|
|
(tail-loop (syntax c)))]
|
|
[(#%plain-app pieces ...)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(for-each loop (syntax->list (syntax (pieces ...)))))]
|
|
[(#%top . var)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(add-id tops (syntax var)))]
|
|
[(define-values vars b)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(add-binders (syntax vars) binders binding-inits #'b)
|
|
(maybe-jump (syntax vars))
|
|
(loop (syntax b)))]
|
|
[(define-syntaxes names exp)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(add-binders (syntax names) binders binding-inits #'exp)
|
|
(maybe-jump (syntax names))
|
|
(level-loop (syntax exp) (+ level 1)))]
|
|
[(begin-for-syntax exp ...)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(for-each (lambda (e) (level-loop e (+ level 1))) (syntax->list (syntax (exp ...)))))]
|
|
[(module m-name lang (#%plain-module-begin bodies ...))
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(hash-set! module-lang-requires (syntax lang) #t)
|
|
(annotate-require-open user-namespace user-directory (syntax lang))
|
|
(hash-cons! requires (syntax->datum (syntax lang)) (syntax lang))
|
|
(for-each loop (syntax->list (syntax (bodies ...)))))]
|
|
[(module* m-name lang (#%plain-module-begin bodies ...))
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(when (syntax-e #'lang)
|
|
(hash-set! module-lang-requires (syntax lang) #t)
|
|
(annotate-require-open user-namespace user-directory (syntax lang))
|
|
(hash-cons! requires (syntax->datum (syntax lang)) (syntax lang)))
|
|
|
|
(for-each loop (syntax->list (syntax (bodies ...)))))]
|
|
|
|
|
|
; top level or module top level only:
|
|
[(#%require raw-require-specs ...)
|
|
(let ()
|
|
(define (handle-raw-require-spec spec)
|
|
(let loop ([spec spec]
|
|
[level level])
|
|
(define (add-to-level n) (and n level (+ n level)))
|
|
(syntax-case* spec (for-meta for-syntax for-template for-label just-meta) symbolic-compare?
|
|
[(for-meta phase specs ...)
|
|
(for ([spec (in-list (syntax->list #'(specs ...)))])
|
|
(loop spec (add-to-level (syntax-e #'phase))))]
|
|
[(for-syntax specs ...)
|
|
(for ([spec (in-list (syntax->list #'(specs ...)))])
|
|
(loop spec (add-to-level 1)))]
|
|
[(for-template specs ...)
|
|
(for ([spec (in-list (syntax->list #'(specs ...)))])
|
|
(loop spec (add-to-level -1)))]
|
|
[(for-label specs ...)
|
|
(for ([spec (in-list (syntax->list #'(specs ...)))])
|
|
(loop spec #f))]
|
|
[(just-meta phase specs ...)
|
|
(for ([spec (in-list (syntax->list #'(specs ...)))])
|
|
(handle-phaseless-spec spec (add-to-level (syntax-e #'phase))))]
|
|
[else
|
|
(handle-phaseless-spec spec level)])))
|
|
(define (handle-phaseless-spec stx level)
|
|
(define require-ht (hash-ref! phase-to-requires level
|
|
(λ ()
|
|
(define h (make-hash))
|
|
(hash-set! phase-to-requires level h)
|
|
h)))
|
|
(define raw-module-path (phaseless-spec->raw-module-path stx))
|
|
(annotate-require-open user-namespace user-directory raw-module-path)
|
|
(when (syntax-original? raw-module-path)
|
|
(define key (syntax->datum raw-module-path))
|
|
(hash-set! require-ht
|
|
key
|
|
(cons stx (hash-ref require-ht key '())))))
|
|
|
|
(for ([spec (in-list (syntax->list #'(raw-require-specs ...)))])
|
|
(handle-raw-require-spec spec)))]
|
|
|
|
; module top level only:
|
|
[(#%provide provide-specs ...)
|
|
(let ([provided-varss (map extract-provided-vars
|
|
(syntax->list (syntax (provide-specs ...))))])
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(for ([provided-vars (in-list provided-varss)])
|
|
(for ([provided-var (in-list provided-vars)])
|
|
(add-id varrefs provided-var))))]
|
|
|
|
[(#%expression arg)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs)
|
|
(tail-loop #'arg))]
|
|
[id
|
|
(identifier? (syntax id))
|
|
(add-id varrefs stx-obj)]
|
|
[_
|
|
(begin
|
|
#;
|
|
(printf "unknown stx: ~.s datum: ~e source: ~e\n"
|
|
sexp
|
|
(and (syntax? sexp)
|
|
(syntax->datum sexp))
|
|
(and (syntax? sexp)
|
|
(syntax-source sexp)))
|
|
(void))])))))
|
|
|
|
(define (hash-cons! ht k v)
|
|
(hash-set! ht k (cons v (hash-ref ht k '()))))
|
|
|
|
;; add-disappeared-bindings : syntax id-set -> void
|
|
(define (add-disappeared-bindings stx binders disappaeared-uses)
|
|
(let ([prop (syntax-property stx 'disappeared-binding)])
|
|
(when prop
|
|
(let loop ([prop prop])
|
|
(cond
|
|
[(pair? prop)
|
|
(loop (car prop))
|
|
(loop (cdr prop))]
|
|
[(identifier? prop)
|
|
(add-origins prop disappaeared-uses)
|
|
(add-id binders prop)])))))
|
|
|
|
;; add-disappeared-uses : syntax id-set -> void
|
|
(define (add-disappeared-uses stx id-set)
|
|
(let ([prop (syntax-property stx 'disappeared-use)])
|
|
(when prop
|
|
(let loop ([prop prop])
|
|
(cond
|
|
[(pair? prop)
|
|
(loop (car prop))
|
|
(loop (cdr prop))]
|
|
[(identifier? prop)
|
|
(add-id id-set prop)])))))
|
|
|
|
;; 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
|
|
;; in the various id-sets
|
|
(define (annotate-variables user-namespace
|
|
user-directory
|
|
phase-to-binders
|
|
phase-to-varrefs
|
|
phase-to-varsets
|
|
phase-to-tops
|
|
templrefs
|
|
module-lang-requires
|
|
phase-to-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))
|
|
|
|
;; 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 requires) (in-hash phase-to-requires)])
|
|
(define new-hash (make-hash))
|
|
(hash-set! unused/phases level new-hash)
|
|
(for ([(k v) (in-hash requires)])
|
|
(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)])
|
|
(document-variable var phase)
|
|
(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)
|
|
(hash-for-each
|
|
unused
|
|
(λ (k v)
|
|
(for-each (λ (stx)
|
|
(unless (hash-ref module-lang-requires stx #f)
|
|
(define defs-text (current-annotations))
|
|
(define source-editor (find-source-editor stx))
|
|
(when (and defs-text source-editor)
|
|
(define pos (syntax-position stx))
|
|
(define span (syntax-span stx))
|
|
(when (and pos span)
|
|
(define start (- pos 1))
|
|
(define fin (+ start span))
|
|
(send defs-text syncheck:add-background-color
|
|
source-editor start fin "firebrick")))
|
|
(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
|
|
(define (id-level phase-level id)
|
|
(let ([binding (identifier-binding id phase-level)])
|
|
(cond [(list? binding)
|
|
(if (self-module? (car binding))
|
|
'top-level
|
|
'imported)]
|
|
[(eq? binding 'lexical) 'lexical]
|
|
[else 'top-level])))
|
|
|
|
(define (self-module? mpi)
|
|
(let-values ([(a b) (module-path-index-split mpi)])
|
|
(and (not a) (not b))))
|
|
|
|
;; connect-identifier : syntax
|
|
;; id-set
|
|
;; (union #f hash-table)
|
|
;; (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?
|
|
connections)
|
|
(define binders (get-ids all-binders var))
|
|
(when binders
|
|
(for ([x (in-list binders)])
|
|
(connect-syntaxes x var actual? (id-level phase-level x) connections)))
|
|
|
|
(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))
|
|
(when (and req-path/pr source-req-path/pr)
|
|
(define req-path (list-ref req-path/pr 0))
|
|
(define id (list-ref req-path/pr 1))
|
|
(define source-req-path (list-ref source-req-path/pr 3))
|
|
(define source-id (list-ref source-req-path/pr 1))
|
|
(define req-phase-level (list-ref req-path/pr 2))
|
|
(define require-ht (hash-ref! phase-to-requires req-phase-level #f))
|
|
(when require-ht
|
|
(define req-stxes (hash-ref require-ht req-path #f))
|
|
(when req-stxes
|
|
(define unused (hash-ref! unused/phases req-phase-level #f))
|
|
(when unused (hash-remove! unused req-path))
|
|
(for ([req-stx (in-list req-stxes)])
|
|
(when (id/require-match? (syntax->datum var)
|
|
id
|
|
(syntax->datum req-stx))
|
|
(when id
|
|
(define filename (get-require-filename source-req-path user-namespace user-directory))
|
|
(when filename
|
|
(add-jump-to-definition
|
|
var
|
|
source-id
|
|
filename)))
|
|
(define raw-module-path (phaseless-spec->raw-module-path req-stx))
|
|
(add-mouse-over var
|
|
(format
|
|
(string-constant cs-mouse-over-import)
|
|
(syntax-e var)
|
|
req-path))
|
|
(connect-syntaxes (if (syntax-source raw-module-path)
|
|
raw-module-path
|
|
req-stx)
|
|
var actual?
|
|
(id-level phase-level var)
|
|
connections))))))))
|
|
|
|
(define (id/require-match? var id req-stx)
|
|
(match req-stx
|
|
[`(only ,_ . ,ids)
|
|
(and (memq id ids)
|
|
(eq? var id))]
|
|
[`(prefix ,prefix ,_)
|
|
(equal? (format "~a~a" prefix id)
|
|
(symbol->string var))]
|
|
[`(all-except ,_ . ,ids)
|
|
(and (eq? var id)
|
|
(not (member var ids)))]
|
|
[`(prefix-all-except ,prefix ,_ . ,rest)
|
|
(and (not (memq id rest))
|
|
(equal? (format "~a~a" prefix id)
|
|
(symbol->string var)))]
|
|
[`(rename ,_ ,local-id ,exported-id)
|
|
(eq? local-id var)]
|
|
[else (eq? var id)]))
|
|
|
|
(define (phaseless-spec->raw-module-path stx)
|
|
(syntax-case* stx (only prefix all-except prefix-all-except rename) symbolic-compare?
|
|
[(only raw-module-path id ...) #'raw-module-path]
|
|
[(prefix prefix-id raw-module-path) #'raw-module-path]
|
|
[(all-except raw-module-path id ...) #'raw-module-path]
|
|
[(prefix-all-except prefix-id raw-module-path id ...) #'raw-module-path]
|
|
[(rename raw-module-path local-id exported-id) #'raw-module-path]
|
|
[_ stx]))
|
|
|
|
|
|
;; get-module-req-path : binding number [#:nominal? boolean] -> (union #f (list require-sexp sym ?? module-path))
|
|
;; argument is the result of identifier-binding or identifier-transformer-binding
|
|
(define (get-module-req-path var phase-level #:nominal? [nominal-source-path? #t])
|
|
(define binding (identifier-binding var phase-level))
|
|
(and (pair? binding)
|
|
(or (not (number? phase-level))
|
|
(= phase-level
|
|
(+ (list-ref binding 5)
|
|
(list-ref binding 6))))
|
|
(let ([mod-path (if nominal-source-path? (list-ref binding 2) (list-ref binding 0))])
|
|
(cond
|
|
[(module-path-index? mod-path)
|
|
(let-values ([(base offset) (module-path-index-split mod-path)])
|
|
(list base
|
|
(if nominal-source-path? (list-ref binding 3) (list-ref binding 1))
|
|
(list-ref binding 5)
|
|
mod-path))]
|
|
[(symbol? mod-path)
|
|
(list mod-path
|
|
(if nominal-source-path? (list-ref binding 3) (list-ref binding 1))
|
|
(list-ref binding 5)
|
|
mod-path)]
|
|
[else #f]))))
|
|
|
|
;; 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])
|
|
(let/ec k
|
|
(namespace-variable-value (syntax-e var) #t (λ () (k #f)))
|
|
#t)))])
|
|
(cond
|
|
[top-bound?
|
|
(color var lexically-bound-variable-style-name)]
|
|
[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 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)
|
|
(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)]))
|
|
|
|
(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 connections)
|
|
(let ([from-source (find-source-editor from)]
|
|
[to-source (find-source-editor to)]
|
|
[defs-text (current-annotations)])
|
|
(when (and from-source to-source defs-text)
|
|
(let ([pos-from (syntax-position from)]
|
|
[span-from (syntax-span from)]
|
|
[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))])
|
|
(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
|
|
actual? level))))))))
|
|
|
|
;; add-jump-to-definition : syntax symbol path -> void
|
|
;; registers the range in the editor so that the
|
|
;; popup menu in this area allows the programmer to jump
|
|
;; to the definition of the id.
|
|
(define (add-jump-to-definition stx id filename)
|
|
(let ([source (find-source-editor stx)]
|
|
[defs-text (current-annotations)])
|
|
(when (and source
|
|
defs-text
|
|
(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-jump-to-definition
|
|
source
|
|
pos-left
|
|
pos-right
|
|
id
|
|
filename)))))
|
|
|
|
;; annotate-require-open : namespace string -> (stx -> void)
|
|
;; relies on current-module-name-resolver, which in turn depends on
|
|
;; current-directory and current-namespace
|
|
(define (annotate-require-open user-namespace user-directory require-spec)
|
|
(when (syntax-original? require-spec)
|
|
(define source (find-source-editor require-spec))
|
|
(when (and source
|
|
(syntax-position require-spec)
|
|
(syntax-span require-spec))
|
|
(define defs-text (current-annotations))
|
|
(when defs-text
|
|
(define start (- (syntax-position require-spec) 1))
|
|
(define end (+ start (syntax-span require-spec)))
|
|
(define file (get-require-filename (syntax->datum require-spec)
|
|
user-namespace
|
|
user-directory))
|
|
(when file
|
|
(send defs-text syncheck:add-require-open-menu
|
|
source start end file))))))
|
|
|
|
;; get-require-filename : sexp-or-module-path-index namespace string[directory] -> filename or #f
|
|
;; finds the filename corresponding to the require in stx
|
|
(define (get-require-filename datum user-namespace user-directory)
|
|
(parameterize ([current-namespace user-namespace]
|
|
[current-directory (or user-directory (current-directory))]
|
|
[current-load-relative-directory user-directory])
|
|
(let* ([rkt-path/mod-path
|
|
(with-handlers ([exn:fail? (λ (x) #f)])
|
|
(cond
|
|
[(module-path-index? datum)
|
|
(resolved-module-path-name
|
|
(module-path-index-resolve datum))]
|
|
[else
|
|
(resolved-module-path-name
|
|
((current-module-name-resolver) datum #f #f))]))]
|
|
[rkt-path/f (and (path? rkt-path/mod-path) rkt-path/mod-path)])
|
|
(let/ec k
|
|
(unless (path? rkt-path/f) (k rkt-path/f))
|
|
(when (file-exists? rkt-path/f) (k rkt-path/f))
|
|
(let* ([bts (path->bytes rkt-path/f)]
|
|
[len (bytes-length bts)])
|
|
(unless (and (len . >= . 4)
|
|
(bytes=? #".rkt" (subbytes bts (- len 4))))
|
|
(k rkt-path/f))
|
|
(let ([ss-path (bytes->path (bytes-append (subbytes bts 0 (- len 4)) #".ss"))])
|
|
(unless (file-exists? ss-path)
|
|
(k rkt-path/f))
|
|
ss-path))))))
|
|
|
|
;; possible-suffixes : (listof string)
|
|
;; these are the suffixes that are checked for the reverse
|
|
;; module-path mapping.
|
|
(define possible-suffixes '(".rkt" ".ss" ".scm" ""))
|
|
|
|
;; module-name-sym->filename : symbol -> (union #f string)
|
|
(define (module-name-sym->filename sym)
|
|
(let ([str (symbol->string sym)])
|
|
(and ((string-length str) . > . 1)
|
|
(char=? (string-ref str 0) #\,)
|
|
(let ([fn (substring str 1 (string-length str))])
|
|
(ormap (λ (x)
|
|
(let ([test (string->path (string-append fn x))])
|
|
(and (file-exists? test)
|
|
test)))
|
|
possible-suffixes)))))
|
|
|
|
;; add-origins : sexp id-set -> void
|
|
(define (add-origins sexp id-set)
|
|
(let ([origin (syntax-property sexp 'origin)])
|
|
(when origin
|
|
(let loop ([ct origin])
|
|
(cond
|
|
[(pair? ct)
|
|
(loop (car ct))
|
|
(loop (cdr ct))]
|
|
[(syntax? ct)
|
|
(add-id id-set ct)]
|
|
[else (void)])))))
|
|
|
|
;; FIXME: handle for-template and for-label
|
|
;; extract-provided-vars : syntax -> (listof syntax[identifier])
|
|
(define (extract-provided-vars stx)
|
|
(syntax-case* stx (rename struct all-from all-from-except all-defined-except) symbolic-compare?
|
|
[identifier
|
|
(identifier? (syntax identifier))
|
|
(list (syntax identifier))]
|
|
|
|
[(rename local-identifier export-identifier)
|
|
(list (syntax local-identifier))]
|
|
|
|
;; why do I even see this?!?
|
|
[(struct struct-identifier (field-identifier ...))
|
|
null]
|
|
|
|
[(all-from module-name) null]
|
|
[(all-from-except module-name identifier ...)
|
|
null]
|
|
[(all-defined-except identifier ...)
|
|
(syntax->list #'(identifier ...))]
|
|
[_
|
|
null]))
|
|
|
|
|
|
;; trim-require-prefix : syntax -> syntax
|
|
(define (trim-require-prefix require-spec)
|
|
(syntax-case* require-spec (only prefix all-except prefix-all-except rename just-meta) symbolic-compare?
|
|
[(only module-name identifier ...)
|
|
(syntax module-name)]
|
|
[(prefix identifier module-name)
|
|
(syntax module-name)]
|
|
[(all-except module-name identifier ...)
|
|
(syntax module-name)]
|
|
[(prefix-all-except module-name identifier ...)
|
|
(syntax module-name)]
|
|
[(rename module-name local-identifier exported-identifier)
|
|
(syntax module-name)]
|
|
[_ require-spec]))
|
|
|
|
(define (symbolic-compare? x y) (eq? (syntax-e x) (syntax-e y)))
|
|
|
|
;; add-binders : syntax id-set (or/c #f id-set) (or/c #f syntax) -> void
|
|
;; transforms an argument list into a bunch of symbols/symbols
|
|
;; and puts them into the id-set
|
|
;; effect: colors the identifiers
|
|
(define (add-binders stx id-set binding-to-init init-exp)
|
|
(let loop ([stx stx])
|
|
(let ([e (if (syntax? stx) (syntax-e stx) stx)])
|
|
(cond
|
|
[(cons? e)
|
|
(let ([fst (car e)]
|
|
[rst (cdr e)])
|
|
(if (syntax? fst)
|
|
(begin
|
|
(when binding-to-init
|
|
(add-init-exp binding-to-init fst init-exp))
|
|
(add-id id-set fst)
|
|
(loop rst))
|
|
(loop rst)))]
|
|
[(null? e) (void)]
|
|
[else
|
|
(when binding-to-init
|
|
(add-init-exp binding-to-init stx init-exp))
|
|
(add-id id-set stx)]))))
|
|
|
|
;; annotate-raw-keyword : syntax id-map -> void
|
|
;; annotates keywords when they were never expanded. eg.
|
|
;; if someone just types `(λ (x) x)' it has no 'origin
|
|
;; field, but there still are keywords.
|
|
(define (annotate-raw-keyword stx id-map)
|
|
(let ([lst (syntax-e stx)])
|
|
(when (pair? lst)
|
|
(let ([f-stx (car lst)])
|
|
(when (identifier? f-stx)
|
|
(add-id id-map f-stx))))))
|
|
|
|
;
|
|
;
|
|
; ;
|
|
; ; ;
|
|
; ; ; ;
|
|
; ;; ; ;;; ;;;; ; ; ; ;; ;; ;;; ; ;; ;;;;; ;;;; ;;;;; ;;; ;;; ; ;;
|
|
; ; ;; ; ; ; ; ; ;; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ;;;; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;
|
|
; ;; ; ;;; ;;;; ;; ; ; ; ; ;;;; ; ; ;;; ;; ; ;;; ; ;;; ; ;
|
|
;
|
|
;
|
|
;
|
|
|
|
|
|
;; document-variable : stx[identifier,original] phase-level -> void
|
|
(define (document-variable stx phase-level)
|
|
(define defs-text (current-annotations))
|
|
(when defs-text
|
|
(define binding-info (identifier-binding stx phase-level))
|
|
(when (and (pair? binding-info)
|
|
(syntax-position stx)
|
|
(syntax-span stx))
|
|
(define start (- (syntax-position stx) 1))
|
|
(define fin (+ start (syntax-span stx)))
|
|
(define source-editor (find-source-editor stx))
|
|
(when source-editor
|
|
(define info (get-index-entry-info binding-info))
|
|
(when info
|
|
(define-values (entry-desc path definition-tag tag) (apply values info))
|
|
(send defs-text syncheck:add-background-color
|
|
source-editor start fin
|
|
"palegreen")
|
|
(send defs-text syncheck:add-docs-menu
|
|
source-editor
|
|
start
|
|
fin
|
|
(syntax-e stx)
|
|
(build-docs-label entry-desc)
|
|
path
|
|
definition-tag
|
|
tag))))))
|
|
|
|
(define (build-docs-label entry-desc)
|
|
(let ([libs (exported-index-desc-from-libs entry-desc)])
|
|
(cond
|
|
[(null? libs)
|
|
(format
|
|
(string-constant cs-view-docs)
|
|
(exported-index-desc-name entry-desc))]
|
|
[else
|
|
(format
|
|
(string-constant cs-view-docs-from)
|
|
(format
|
|
(string-constant cs-view-docs)
|
|
(exported-index-desc-name entry-desc))
|
|
(apply string-append
|
|
(add-between
|
|
(map (λ (x) (format "~s" x)) libs)
|
|
", ")))])))
|
|
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ;
|
|
; ;
|
|
;
|
|
; ; ;; ;;; ;;;; ;;;; ;;;;; ; ;;;; ;;;;
|
|
; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;
|
|
; ; ;;; ; ; ;; ; ; ; ; ; ; ; ;;;;
|
|
; ;
|
|
; ; ;
|
|
; ;;;
|
|
|
|
|
|
;; make-rename-menus : (listof phase-to-mapping) -> void
|
|
(define (make-rename-menus phase-tos)
|
|
|
|
;; table : symbol -o> (listof (pair (non-empty-listof identifier?)
|
|
;; (non-empty-setof (list ed start fin))))
|
|
;; this table maps the names of identifiers to information that tells how to build
|
|
;; the rename menus.
|
|
;;
|
|
;; In the simple case that every identifier in the file has a different
|
|
;; name, then each of the symbols in the table will map to a singleton list where the
|
|
;; listof identifiers is also a singleton list and each of the '(list ed start fin)'
|
|
;; corresponds to the locations of that identifier in the file.
|
|
;;
|
|
;; In the more common case, there will be multiple, distinct uses of an identifier that
|
|
;; is spelled the same way in the file, eg (+ (let ([x 1]) x) (let ([x 2]) x)). In
|
|
;; this case, the 'x' entry in the table will point to a list of length two,
|
|
;; with each of the corresponding list of identifiers in the pair still being a
|
|
;; singleton list.
|
|
;;
|
|
;; In the bizarro case, some macro will have taken an identifier from its input and
|
|
;; put it into two distinct binding locations, eg:
|
|
;; (define-syntax-rule (m x) (begin (define x 1) (lambda (x) x)))
|
|
;; In this case, there is only one 'x' in the original program, but there are two
|
|
;; distinct identifiers (according to free-identifier=?) in the program. To cope
|
|
;; with this, the code below recognizes that two distinct identifiers come from the
|
|
;; same source location and then puts those two identifiers into the first list into
|
|
;; the same 'pair' in the table, unioning the corresponding sets of source locations
|
|
;;
|
|
|
|
(define table (make-hash))
|
|
(struct pair (ids locs) #:transparent)
|
|
|
|
(let ([defs-text (current-annotations)])
|
|
(when defs-text
|
|
(for ([phase-to-mapping (in-list phase-tos)])
|
|
(for ([(level id-set) (in-hash phase-to-mapping)])
|
|
(for-each-ids
|
|
id-set
|
|
(λ (vars)
|
|
(for ([var (in-list vars)])
|
|
(define ed (find-source-editor var))
|
|
(when ed
|
|
(define pos (syntax-position var))
|
|
(define span (syntax-span var))
|
|
(when (and pos span)
|
|
(define start (- pos 1))
|
|
(define fin (+ start span))
|
|
(define loc (list ed start fin))
|
|
(define var-sym (syntax-e var))
|
|
|
|
(define current-pairs (hash-ref table var-sym '()))
|
|
(define free-id-matching-pair #f)
|
|
(define added-source-loc-sets '())
|
|
(define new-pairs
|
|
(for/list ([a-pair (in-list current-pairs)])
|
|
(define ids (pair-ids a-pair))
|
|
(define loc-set (pair-locs a-pair))
|
|
(cond
|
|
[(ormap (λ (this-id) (free-identifier=? this-id var)) ids)
|
|
(define new-pair (pair ids (set-add loc-set loc)))
|
|
(set! free-id-matching-pair new-pair)
|
|
new-pair]
|
|
[(set-member? loc-set loc)
|
|
;; here we are in the biazarro case;
|
|
;; we found this source location in a set that corresponds to
|
|
;; some other identifier. so, we know we need to do some kind of a merger
|
|
;; just keep track of the set for now, the merger happens after this loop
|
|
(set! added-source-loc-sets (cons a-pair added-source-loc-sets))
|
|
a-pair]
|
|
[else
|
|
a-pair])))
|
|
|
|
;; first step in updating the table; put the new set in.
|
|
(cond
|
|
[free-id-matching-pair
|
|
(hash-set! table var-sym new-pairs)]
|
|
[else
|
|
(set! free-id-matching-pair (pair (list var) (set loc)))
|
|
(hash-set! table var-sym (cons free-id-matching-pair new-pairs))])
|
|
|
|
(unless (null? added-source-loc-sets)
|
|
;; here we are in the bizarro case; we need to union the sets
|
|
;; in the added-source-loc-sets list.
|
|
(define pairs-to-merge (cons free-id-matching-pair added-source-loc-sets))
|
|
(define removed-sets (filter (λ (x) (not (memq x pairs-to-merge)))
|
|
(hash-ref table var-sym)))
|
|
(define new-pair (pair (apply append (map pair-ids pairs-to-merge))
|
|
(apply set-union (map pair-locs pairs-to-merge))))
|
|
(hash-set! table var-sym (cons new-pair removed-sets))))))))))
|
|
|
|
(hash-for-each
|
|
table
|
|
(λ (id-as-sym pairs)
|
|
(for ([a-pair (in-list pairs)])
|
|
(define loc-lst (set->list (pair-locs a-pair)))
|
|
(define ids (pair-ids a-pair))
|
|
(define (name-dup? new-str)
|
|
(and (for/or ([phase-to-map (in-list phase-tos)])
|
|
(for/or ([(level id-set) (in-hash phase-to-map)])
|
|
(for/or ([id (in-list ids)])
|
|
(for/or ([corresponding-id (in-list (or (get-ids id-set id) '()))])
|
|
(let ([new-id (datum->syntax corresponding-id (string->symbol new-str))])
|
|
(for/or ([phase-to-map (in-list phase-tos)])
|
|
(for/or ([(level id-set) (in-hash phase-to-map)])
|
|
(get-ids id-set new-id))))))))
|
|
#t))
|
|
(define max-to-send-at-once 30)
|
|
(let loop ([loc-lst loc-lst]
|
|
[len (length loc-lst)])
|
|
(cond
|
|
[(<= len max-to-send-at-once)
|
|
(send defs-text syncheck:add-rename-menu
|
|
id-as-sym
|
|
loc-lst
|
|
name-dup?)]
|
|
[else
|
|
(send defs-text syncheck:add-rename-menu
|
|
id-as-sym
|
|
(take loc-lst max-to-send-at-once)
|
|
name-dup?)
|
|
(loop (drop loc-lst max-to-send-at-once)
|
|
(- len max-to-send-at-once))]))))))))
|
|
|
|
;; remove-duplicates-stx : (listof syntax[original]) -> (listof syntax[original])
|
|
;; removes duplicates, based on the source locations of the identifiers
|
|
(define (remove-duplicates-stx ids)
|
|
(cond
|
|
[(null? ids) null]
|
|
[else (let loop ([fst (car ids)]
|
|
[rst (cdr ids)])
|
|
(cond
|
|
[(null? rst) (list fst)]
|
|
[else (if (and (eq? (syntax-source fst)
|
|
(syntax-source (car rst)))
|
|
(= (syntax-position fst)
|
|
(syntax-position (car rst))))
|
|
(loop fst (cdr rst))
|
|
(cons fst (loop (car rst) (cdr rst))))]))]))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ;
|
|
; ;
|
|
; ; ;
|
|
; ; ;; ; ;;; ;;; ;;;; ;;;
|
|
; ; ; ;; ; ; ; ; ;
|
|
; ; ; ; ;; ; ; ; ;;
|
|
; ; ; ; ;; ;;;;;; ; ;;
|
|
; ; ; ; ; ; ; ;
|
|
; ; ; ;; ; ; ; ;
|
|
; ; ;; ; ;;; ;;;; ;; ;;;
|
|
;
|
|
;
|
|
;
|
|
|
|
|
|
(define (lookup-phase-to-mapping phase-to n)
|
|
(hash-ref! phase-to n (λ () (make-id-set))))
|
|
|
|
;; make-id-set : -> id-set
|
|
(define (make-id-set) (make-free-identifier-mapping))
|
|
|
|
;; add-init-exp : id-set identifier stx -> void
|
|
(define (add-init-exp mapping id init-exp)
|
|
(when (syntax-original? id)
|
|
(let* ([old (free-identifier-mapping-get mapping id (λ () '()))]
|
|
[new (cons init-exp old)])
|
|
(free-identifier-mapping-put! mapping id new))))
|
|
|
|
;; add-id : id-set identifier -> void
|
|
(define (add-id mapping id)
|
|
(when (syntax-original? id)
|
|
(let* ([old (free-identifier-mapping-get mapping id (λ () '()))]
|
|
[new (cons id old)])
|
|
(free-identifier-mapping-put! mapping id new))))
|
|
|
|
;; get-idss : id-set -> (listof (listof identifier))
|
|
(define (get-idss mapping)
|
|
(free-identifier-mapping-map mapping (λ (x y) y)))
|
|
|
|
;; get-ids : id-set identifier -> (union (listof identifier) #f)
|
|
(define (get-ids mapping var)
|
|
(free-identifier-mapping-get mapping var (λ () #f)))
|
|
|
|
;; for-each-ids : id-set ((listof identifier) -> void) -> void
|
|
(define (for-each-ids mapping f)
|
|
(free-identifier-mapping-for-each mapping (λ (x y) (f y))))
|