d381eb5051
One problem with commit 299063d7c1
is that the new method for computing the lime green arrows no
longer has the information necessary to distinguish different
identifiers that come from the same require.
This means that, before this commit, mousing over an imported
identifier can be a real interactivity killer. So, instead of
adding more information to distinguish those ids, lets just
try not draw the lime green bubbles for imported identifiers
and see how that feels
1132 lines
56 KiB
Racket
1132 lines
56 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
|
|
scribble/manual-struct)
|
|
|
|
(provide make-traversal
|
|
current-max-to-send-at-once)
|
|
|
|
(define current-max-to-send-at-once (make-parameter +inf.0))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ;
|
|
; ;
|
|
; ; ; ;
|
|
; ;;; ; ; ; ;; ;;;; ;;; ; ; ;;;; ; ; ;;; ; ; ;;; ; ; ;;; ;;; ; ;;;
|
|
; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ;
|
|
; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;;
|
|
; ;; ; ; ; ; ; ;;;; ; ; ; ;;;; ; ; ;;;;;; ; ;; ;;;; ; ;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;; ; ; ; ;; ;;;;; ; ; ;; ; ;;;;; ; ;;;; ; ;;; ;;;;; ; ;;;
|
|
; ;
|
|
; ;
|
|
; ;
|
|
|
|
|
|
|
|
;; 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 [ignored 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
|
|
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
|
|
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]
|
|
;; id-set (8 of them)
|
|
;; hash-table[require-spec -> syntax] (three of them)
|
|
;; -> void
|
|
(define (annotate-basic stx-obj
|
|
user-namespace user-directory
|
|
phase-to-binders
|
|
phase-to-varrefs
|
|
phase-to-varsets
|
|
phase-to-tops
|
|
binding-inits
|
|
templrefs
|
|
module-lang-requires
|
|
phase-to-requires)
|
|
|
|
(let level+tail+mod-loop ([stx-obj stx-obj]
|
|
[level 0]
|
|
[level-of-enclosing-module 0]
|
|
[tail-parent-src #f]
|
|
[tail-parent-pos #f]
|
|
;; mods: (or/f #f ; => outside a module
|
|
;; '() ; => inside the main module in this file
|
|
;; '(name names ...) ; => inside some submodules named by name & names
|
|
[mods #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+mod-loop sexp level level-of-enclosing-module
|
|
#f #f
|
|
mods))]
|
|
[tail-loop (λ (sexp) (level+tail+mod-loop sexp level level-of-enclosing-module
|
|
next-tail-parent-src next-tail-parent-pos
|
|
mods))]
|
|
[mod-loop (λ (sexp mod) (level+tail+mod-loop sexp 0
|
|
(+ level level-of-enclosing-module)
|
|
#f #f
|
|
(if mods
|
|
(cons mod mods)
|
|
'())))]
|
|
[loop (λ (sexp) (level+tail+mod-loop sexp level level-of-enclosing-module #f #f mods))]
|
|
[varrefs (lookup-phase-to-mapping phase-to-varrefs (+ level level-of-enclosing-module))]
|
|
[varsets (lookup-phase-to-mapping phase-to-varsets (+ level level-of-enclosing-module))]
|
|
[binders (lookup-phase-to-mapping phase-to-binders (+ level level-of-enclosing-module))]
|
|
[tops (lookup-phase-to-mapping phase-to-tops (+ level level-of-enclosing-module))]
|
|
[requires (hash-ref! phase-to-requires (+ level level-of-enclosing-module) (λ () (make-hash)))]
|
|
[collect-general-info
|
|
(λ (stx)
|
|
(add-origins stx varrefs level-of-enclosing-module)
|
|
(add-disappeared-bindings stx binders varrefs level-of-enclosing-module)
|
|
(add-disappeared-uses stx varrefs level-of-enclosing-module))])
|
|
(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 level-of-enclosing-module)
|
|
(add-binders (syntax args) binders #f #f level-of-enclosing-module)
|
|
(list-loop/tail-last (syntax->list (syntax (bodies ...)))))]
|
|
[(case-lambda [argss bodiess ...]...)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
|
(for-each
|
|
(λ (args bodies)
|
|
(add-binders args binders #f #f level-of-enclosing-module)
|
|
(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 level-of-enclosing-module)
|
|
(loop (syntax test))
|
|
(tail-loop (syntax then))
|
|
(tail-loop (syntax else)))]
|
|
[(begin bodies ...)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
|
(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 level-of-enclosing-module)
|
|
(tail-loop (syntax body)))]
|
|
|
|
[(begin0 bodies ...)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
|
(for-each loop (syntax->list (syntax (bodies ...)))))]
|
|
|
|
[(let-values (bindings ...) bs ...)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
|
(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 level-of-enclosing-module))
|
|
(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 level-of-enclosing-module)
|
|
(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 level-of-enclosing-module))
|
|
(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 level-of-enclosing-module)
|
|
|
|
;; 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) level-of-enclosing-module)
|
|
(if (identifier-binding (syntax var) 0)
|
|
(add-id varrefs (syntax var) level-of-enclosing-module)
|
|
(add-id tops (syntax var) level-of-enclosing-module))
|
|
|
|
(loop (syntax e)))]
|
|
[(quote datum)
|
|
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)]
|
|
[(quote-syntax datum)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
|
(let loop ([stx #'datum])
|
|
(cond [(identifier? stx)
|
|
(add-id templrefs stx level-of-enclosing-module)]
|
|
[(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 level-of-enclosing-module)
|
|
(loop (syntax a))
|
|
(loop (syntax b))
|
|
(tail-loop (syntax c)))]
|
|
[(#%plain-app pieces ...)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
|
(for-each loop (syntax->list (syntax (pieces ...)))))]
|
|
[(#%top . var)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
|
(add-id tops (syntax var) level-of-enclosing-module))]
|
|
[(define-values vars b)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
|
(add-binders (syntax vars) binders binding-inits #'b level-of-enclosing-module)
|
|
(add-definition-target (syntax vars) mods)
|
|
(loop (syntax b)))]
|
|
[(define-syntaxes names exp)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
|
(add-binders (syntax names) binders binding-inits #'exp level-of-enclosing-module)
|
|
(add-definition-target (syntax names) mods)
|
|
(level-loop (syntax exp) (+ level 1)))]
|
|
[(begin-for-syntax exp ...)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
|
(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 level-of-enclosing-module)
|
|
(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 ([body (in-list (syntax->list (syntax (bodies ...))))])
|
|
(mod-loop body (syntax-e #'m-name))))]
|
|
[(module* m-name lang (#%plain-module-begin bodies ...))
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
|
(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 ([body (in-list (syntax->list (syntax (bodies ...))))])
|
|
(mod-loop body (syntax-e #'m-name))))]
|
|
|
|
|
|
; 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 adjusted-level (and level (+ level level-of-enclosing-module)))
|
|
(define require-ht (hash-ref! phase-to-requires
|
|
adjusted-level
|
|
(λ ()
|
|
(define h (make-hash))
|
|
(hash-set! phase-to-requires adjusted-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 level-of-enclosing-module)
|
|
(for ([provided-vars (in-list provided-varss)])
|
|
(for ([provided-var (in-list provided-vars)])
|
|
(add-id varrefs provided-var level-of-enclosing-module))))]
|
|
|
|
[(#%expression arg)
|
|
(begin
|
|
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
|
|
(tail-loop #'arg))]
|
|
[id
|
|
(identifier? (syntax id))
|
|
(add-id varrefs stx-obj level-of-enclosing-module)]
|
|
[_
|
|
(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 integer -> void
|
|
(define (add-disappeared-bindings stx binders disappaeared-uses level-of-enclosing-module)
|
|
(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 level-of-enclosing-module)
|
|
(add-id binders prop level-of-enclosing-module)])))))
|
|
|
|
;; add-disappeared-uses : syntax id-set integer -> void
|
|
(define (add-disappeared-uses stx id-set level-of-enclosing-module)
|
|
(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 level-of-enclosing-module)])))))
|
|
|
|
;; 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))))
|
|
|
|
|
|
;; 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)))
|
|
|
|
(for ([vars (in-list (get-idss templrefs))])
|
|
(for ([var (in-list vars)])
|
|
|
|
;; 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))
|
|
|
|
;; 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? all-binders (id-level phase-level x) connections #f)))
|
|
|
|
(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-values (filename submods) (get-require-filename source-req-path user-namespace user-directory))
|
|
(when filename
|
|
(add-jump-to-definition
|
|
var
|
|
source-id
|
|
filename
|
|
submods)))
|
|
(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? all-binders
|
|
(id-level phase-level var)
|
|
connections
|
|
#t))))))))
|
|
|
|
(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 : identifier number [#:nominal? boolean] -> (union #f (list require-sexp sym ?? module-path))
|
|
(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 (get-str) (send (list-ref key 0) get-text (list-ref key 1) (list-ref key 2)))
|
|
(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? all-binders level connections require-arrow?)
|
|
(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)))))
|
|
(define (name-dup? str)
|
|
(define sym (string->symbol str))
|
|
(define id1 (datum->syntax from sym))
|
|
(define id2 (datum->syntax to sym)) ;; do I need both?
|
|
(define ans #f)
|
|
(for-each-ids
|
|
all-binders
|
|
(λ (ids)
|
|
(set! ans (or ans
|
|
(for/or ([id (in-list ids)])
|
|
(or (free-identifier=? id1 id)
|
|
(free-identifier=? id2 id)))))))
|
|
ans)
|
|
(send defs-text syncheck:add-arrow/name-dup
|
|
from-source from-pos-left from-pos-right
|
|
to-source to-pos-left to-pos-right
|
|
actual? level require-arrow? name-dup?))))))))
|
|
|
|
;; 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 submods)
|
|
(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
|
|
submods)))))
|
|
|
|
;; 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-values (file submods)
|
|
(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])
|
|
(define mpi
|
|
(with-handlers ([exn:fail? (λ (x) #f)])
|
|
(cond
|
|
[(module-path-index? datum)
|
|
(module-path-index-resolve datum)]
|
|
[else
|
|
((current-module-name-resolver) datum #f #f)])))
|
|
(define rkt-path/mod-path (and mpi (resolved-module-path-name mpi)))
|
|
(define rkt-path/f (cond
|
|
[(path? rkt-path/mod-path) rkt-path/mod-path]
|
|
[(and (pair? rkt-path/mod-path)
|
|
(path? (car rkt-path/mod-path)))
|
|
(car rkt-path/mod-path)]
|
|
[else #f]))
|
|
(define rkt-submods (cond
|
|
[(not rkt-path/mod-path) #f]
|
|
[(or (symbol? rkt-path/mod-path) (path? rkt-path/mod-path)) '()]
|
|
[(pair? rkt-path/mod-path) (cdr rkt-path/mod-path)]))
|
|
(define cleaned-up-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))))
|
|
(values cleaned-up-path rkt-submods)))
|
|
|
|
;; 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 integer -> void
|
|
(define (add-origins sexp id-set level-of-enclosing-module)
|
|
(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 level-of-enclosing-module)]
|
|
[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) integer -> 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 level-of-enclosing-module)
|
|
(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 level-of-enclosing-module)
|
|
(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 level-of-enclosing-module)]))))
|
|
|
|
;; add-definition-target : syntax[(sequence of identifiers)] (listof symbol) -> void
|
|
(define (add-definition-target stx mods)
|
|
(when mods
|
|
(define defs-text (current-annotations))
|
|
(for ([id (in-list (syntax->list stx))])
|
|
(define source (syntax-source id))
|
|
(when (and source
|
|
defs-text
|
|
(syntax-position id)
|
|
(syntax-span id))
|
|
(let* ([pos-left (- (syntax-position id) 1)]
|
|
[pos-right (+ pos-left (syntax-span id))])
|
|
(send defs-text syncheck:add-definition-target
|
|
source
|
|
pos-left
|
|
pos-right
|
|
(syntax-e id)
|
|
mods))))))
|
|
|
|
;; annotate-raw-keyword : syntax id-map integer -> 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 level-of-enclosing-module)
|
|
(let ([lst (syntax-e stx)])
|
|
(when (pair? lst)
|
|
(let ([f-stx (car lst)])
|
|
(when (identifier? f-stx)
|
|
(add-id id-map f-stx level-of-enclosing-module))))))
|
|
|
|
;
|
|
;
|
|
; ;
|
|
; ; ;
|
|
; ; ; ;
|
|
; ;; ; ;;; ;;;; ; ; ; ;; ;; ;;; ; ;; ;;;;; ;;;; ;;;;; ;;; ;;; ; ;;
|
|
; ; ;; ; ; ; ; ; ;; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ;;;; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;
|
|
; ;; ; ;;; ;;;; ;; ; ; ; ; ;;;; ; ; ;;; ;; ; ;;; ; ;;; ; ;
|
|
;
|
|
;
|
|
;
|
|
|
|
|
|
;; 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)
|
|
", ")))])))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ;
|
|
; ;
|
|
; ; ;
|
|
; ; ;; ; ;;; ;;; ;;;; ;;;
|
|
; ; ; ;; ; ; ; ; ;
|
|
; ; ; ; ;; ; ; ; ;;
|
|
; ; ; ; ;; ;;;;;; ; ;;
|
|
; ; ; ; ; ; ; ;
|
|
; ; ; ;; ; ; ; ;
|
|
; ; ;; ; ;;; ;;;; ;; ;;;
|
|
;
|
|
;
|
|
;
|
|
|
|
|
|
(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 (original-enough? 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 level-of-enclosing-module)
|
|
(when (original-enough? id)
|
|
(let* ([id (syntax-shift-phase-level id level-of-enclosing-module)]
|
|
[old (free-identifier-mapping-get mapping id (λ () '()))]
|
|
[new (cons id old)])
|
|
(free-identifier-mapping-put! mapping id new))))
|
|
|
|
(define (original-enough? x)
|
|
(or (syntax-original? x)
|
|
(syntax-property x 'original-for-check-syntax)))
|
|
|
|
;; 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))))
|