Removing source-editor-cache from Check Syntax, since text:lookup-port-name should be sufficient.
svn: r10580
This commit is contained in:
Danny Yoo
parent
d25e834f2c
commit
ee8f0b410f
|
|
@ -29,6 +29,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(prefix-in drscheme:arrow: drscheme/arrow)
|
||||
(prefix-in fw: framework/framework)
|
||||
mred
|
||||
framework
|
||||
setup/xref
|
||||
scribble/xref
|
||||
scribble/manual-struct
|
||||
|
|
@ -1344,7 +1345,6 @@ If the namespace does not, they are colored the unbound color.
|
|||
[tl-require-for-syntaxes (make-hash)]
|
||||
[tl-require-for-templates (make-hash)]
|
||||
[tl-require-for-labels (make-hash)]
|
||||
[source-editor-cache (make-hasheq)]
|
||||
[expanded-expression
|
||||
(λ (user-namespace user-directory sexp jump-to-id)
|
||||
(parameterize ([current-load-relative-directory user-directory])
|
||||
|
|
@ -1364,13 +1364,12 @@ If the namespace does not, they are colored the unbound color.
|
|||
[require-for-syntaxes (make-hash)]
|
||||
[require-for-templates (make-hash)]
|
||||
[require-for-labels (make-hash)])
|
||||
(annotate-basic sexp source-editor-cache
|
||||
(annotate-basic sexp
|
||||
user-namespace user-directory jump-to-id
|
||||
low-binders high-binders varrefs high-varrefs low-tops high-tops
|
||||
templrefs
|
||||
requires require-for-syntaxes require-for-templates require-for-labels)
|
||||
(annotate-variables source-editor-cache
|
||||
user-namespace
|
||||
(annotate-variables user-namespace
|
||||
user-directory
|
||||
low-binders
|
||||
high-binders
|
||||
|
|
@ -1384,7 +1383,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
require-for-templates
|
||||
require-for-labels))]
|
||||
[else
|
||||
(annotate-basic sexp source-editor-cache
|
||||
(annotate-basic sexp
|
||||
user-namespace user-directory jump-to-id
|
||||
tl-low-binders tl-high-binders
|
||||
tl-low-varrefs tl-high-varrefs
|
||||
|
|
@ -1397,8 +1396,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
[expansion-completed
|
||||
(λ (user-namespace user-directory)
|
||||
(parameterize ([current-load-relative-directory user-directory])
|
||||
(annotate-variables source-editor-cache
|
||||
user-namespace
|
||||
(annotate-variables user-namespace
|
||||
user-directory
|
||||
tl-low-binders
|
||||
tl-high-binders
|
||||
|
|
@ -1418,7 +1416,6 @@ If the namespace does not, they are colored the unbound color.
|
|||
(define-struct req/tag (req-stx req-sexp used?))
|
||||
|
||||
;; annotate-basic : syntax
|
||||
;; hash-table[source-editor-cache]
|
||||
;; namespace
|
||||
;; string[directory]
|
||||
;; syntax[id]
|
||||
|
|
@ -1426,7 +1423,6 @@ If the namespace does not, they are colored the unbound color.
|
|||
;; hash-table[require-spec -> syntax] (three of them)
|
||||
;; -> void
|
||||
(define (annotate-basic sexp
|
||||
source-editor-cache
|
||||
user-namespace user-directory jump-to-id
|
||||
low-binders high-binders
|
||||
low-varrefs high-varrefs
|
||||
|
|
@ -1443,7 +1439,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(when (pair? binding)
|
||||
(let ([nominal-source-id (list-ref binding 3)])
|
||||
(when (eq? nominal-source-id jump-to-id)
|
||||
(jump-to source-editor-cache id))))))
|
||||
(jump-to id))))))
|
||||
(syntax->list vars))))])
|
||||
|
||||
(let level-loop ([sexp sexp]
|
||||
|
|
@ -1544,10 +1540,10 @@ If the namespace does not, they are colored the unbound color.
|
|||
|
||||
(loop (syntax e)))]
|
||||
[(quote datum)
|
||||
;(color-internal-structure source-editor-cache (syntax datum) constant-style-name)
|
||||
;(color-internal-structure (syntax datum) constant-style-name)
|
||||
(annotate-raw-keyword sexp varrefs)]
|
||||
[(quote-syntax datum)
|
||||
;(color-internal-structure source-editor-cache (syntax datum) constant-style-name)
|
||||
;(color-internal-structure (syntax datum) constant-style-name)
|
||||
(annotate-raw-keyword sexp varrefs)
|
||||
(let loop ([stx #'datum])
|
||||
(cond [(identifier? stx)
|
||||
|
|
@ -1600,7 +1596,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
[(module m-name lang (#%plain-module-begin bodies ...))
|
||||
(begin
|
||||
(annotate-raw-keyword sexp varrefs)
|
||||
((annotate-require-open source-editor-cache user-namespace user-directory) (syntax lang))
|
||||
((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 ...)))))]
|
||||
|
|
@ -1621,8 +1617,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(let ([new-specs (map trim-require-prefix
|
||||
(syntax->list (syntax (require-specs ... ...))))])
|
||||
(annotate-raw-keyword sexp varrefs)
|
||||
(for-each (annotate-require-open source-editor-cache
|
||||
user-namespace
|
||||
(for-each (annotate-require-open user-namespace
|
||||
user-directory)
|
||||
new-specs)
|
||||
(for-each (add-require-spec requires)
|
||||
|
|
@ -1685,7 +1680,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(and (syntax? sexp)
|
||||
(syntax-source sexp)))
|
||||
(void))])))
|
||||
(add-tail-ht-links source-editor-cache tail-ht)))
|
||||
(add-tail-ht-links tail-ht)))
|
||||
|
||||
(define (hash-cons! ht k v)
|
||||
(hash-set! ht k (cons v (hash-ref ht k '()))))
|
||||
|
|
@ -1733,8 +1728,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
;; 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 source-editor-cache
|
||||
user-namespace
|
||||
(define (annotate-variables user-namespace
|
||||
user-directory
|
||||
low-binders
|
||||
high-binders
|
||||
|
|
@ -1772,7 +1766,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(for-each (λ (vars)
|
||||
(for-each (λ (var)
|
||||
(when (syntax-original? var)
|
||||
(color-variable source-editor-cache var identifier-binding)
|
||||
(color-variable var identifier-binding)
|
||||
(document-variable var identifier-binding)
|
||||
(record-renamable-var rename-ht var)))
|
||||
vars))
|
||||
|
|
@ -1781,10 +1775,9 @@ If the namespace does not, they are colored the unbound color.
|
|||
|
||||
(for-each (λ (vars) (for-each
|
||||
(λ (var)
|
||||
(color-variable source-editor-cache var identifier-binding)
|
||||
(color-variable var identifier-binding)
|
||||
(document-variable var identifier-binding)
|
||||
(connect-identifier source-editor-cache
|
||||
var
|
||||
(connect-identifier var
|
||||
rename-ht
|
||||
low-binders
|
||||
unused-requires
|
||||
|
|
@ -1798,10 +1791,9 @@ If the namespace does not, they are colored the unbound color.
|
|||
|
||||
(for-each (λ (vars) (for-each
|
||||
(λ (var)
|
||||
(color-variable source-editor-cache var identifier-transformer-binding)
|
||||
(color-variable var identifier-transformer-binding)
|
||||
(document-variable var identifier-transformer-binding)
|
||||
(connect-identifier source-editor-cache
|
||||
var
|
||||
(connect-identifier var
|
||||
rename-ht
|
||||
high-binders
|
||||
unused-require-for-syntaxes
|
||||
|
|
@ -1816,8 +1808,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(for-each (lambda (vars) (for-each
|
||||
(lambda (var)
|
||||
;; no color variable
|
||||
(connect-identifier source-editor-cache
|
||||
var
|
||||
(connect-identifier var
|
||||
rename-ht
|
||||
low-binders
|
||||
unused-requires
|
||||
|
|
@ -1826,8 +1817,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
user-namespace
|
||||
user-directory
|
||||
#f)
|
||||
(connect-identifier source-editor-cache
|
||||
var
|
||||
(connect-identifier var
|
||||
rename-ht
|
||||
high-binders
|
||||
unused-require-for-syntaxes
|
||||
|
|
@ -1836,8 +1826,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
user-namespace
|
||||
user-directory
|
||||
#f)
|
||||
(connect-identifier source-editor-cache
|
||||
var
|
||||
(connect-identifier var
|
||||
rename-ht
|
||||
template-binders ;; dummy; always empty
|
||||
unused-require-for-templates
|
||||
|
|
@ -1846,8 +1835,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
user-namespace
|
||||
user-directory
|
||||
#f)
|
||||
(connect-identifier source-editor-cache
|
||||
var
|
||||
(connect-identifier var
|
||||
rename-ht
|
||||
label-binders ;; dummy; always empty
|
||||
unused-require-for-labels
|
||||
|
|
@ -1863,7 +1851,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(λ (vars)
|
||||
(for-each
|
||||
(λ (var)
|
||||
(color/connect-top source-editor-cache rename-ht user-namespace user-directory low-binders var))
|
||||
(color/connect-top rename-ht user-namespace user-directory low-binders var))
|
||||
vars))
|
||||
(get-idss low-tops))
|
||||
|
||||
|
|
@ -1871,15 +1859,15 @@ If the namespace does not, they are colored the unbound color.
|
|||
(λ (vars)
|
||||
(for-each
|
||||
(λ (var)
|
||||
(color/connect-top source-editor-cache rename-ht user-namespace user-directory high-binders var))
|
||||
(color/connect-top rename-ht user-namespace user-directory high-binders var))
|
||||
vars))
|
||||
(get-idss high-tops))
|
||||
|
||||
(color-unused source-editor-cache require-for-labels unused-require-for-labels)
|
||||
(color-unused source-editor-cache require-for-templates unused-require-for-templates)
|
||||
(color-unused source-editor-cache require-for-syntaxes unused-require-for-syntaxes)
|
||||
(color-unused source-editor-cache requires unused-requires)
|
||||
(hash-for-each rename-ht (lambda (k stxs) (make-rename-menu source-editor-cache stxs id-sets)))))
|
||||
(color-unused require-for-labels unused-require-for-labels)
|
||||
(color-unused require-for-templates unused-require-for-templates)
|
||||
(color-unused require-for-syntaxes unused-require-for-syntaxes)
|
||||
(color-unused requires unused-requires)
|
||||
(hash-for-each rename-ht (lambda (k stxs) (make-rename-menu stxs id-sets)))))
|
||||
|
||||
;; record-renamable-var : rename-ht syntax -> void
|
||||
(define (record-renamable-var rename-ht stx)
|
||||
|
|
@ -1889,15 +1877,14 @@ If the namespace does not, they are colored the unbound color.
|
|||
(cons stx (hash-ref rename-ht key '())))))
|
||||
|
||||
;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] -> void
|
||||
(define (color-unused source-editor-cache requires unused)
|
||||
(define (color-unused requires unused)
|
||||
(hash-for-each
|
||||
unused
|
||||
(λ (k v)
|
||||
(for-each (λ (stx) (color source-editor-cache stx error-style-name))
|
||||
(for-each (λ (stx) (color stx error-style-name))
|
||||
(hash-ref requires k)))))
|
||||
|
||||
;; connect-identifier : hash-table[source-editor-cache]
|
||||
;; syntax
|
||||
;; connect-identifier : syntax
|
||||
;; id-set
|
||||
;; (union #f hash-table)
|
||||
;; (union #f hash-table)
|
||||
|
|
@ -1908,15 +1895,14 @@ If the namespace does not, they are colored the unbound color.
|
|||
;; boolean
|
||||
;; -> void
|
||||
;; adds arrows and rename menus for binders/bindings
|
||||
(define (connect-identifier source-editor-cache var rename-ht all-binders
|
||||
(define (connect-identifier var rename-ht all-binders
|
||||
unused requires get-binding user-namespace user-directory actual?)
|
||||
(connect-identifier/arrow source-editor-cache var all-binders
|
||||
(connect-identifier/arrow var all-binders
|
||||
unused requires get-binding user-namespace user-directory actual?)
|
||||
(when (and actual? (get-ids all-binders var))
|
||||
(record-renamable-var rename-ht var)))
|
||||
|
||||
;; connect-identifier/arrow : syntax
|
||||
;; hash-table[source-editor-cache]
|
||||
;; id-set
|
||||
;; (union #f hash-table)
|
||||
;; (union #f hash-table)
|
||||
|
|
@ -1924,12 +1910,12 @@ If the namespace does not, they are colored the unbound color.
|
|||
;; boolean
|
||||
;; -> void
|
||||
;; adds the arrows that correspond to binders/bindings
|
||||
(define (connect-identifier/arrow source-editor-cache var all-binders unused requires get-binding user-namespace user-directory actual?)
|
||||
(define (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?)
|
||||
(let ([binders (get-ids all-binders var)])
|
||||
(when binders
|
||||
(for-each (λ (x)
|
||||
(when (syntax-original? x)
|
||||
(connect-syntaxes source-editor-cache x var actual?)))
|
||||
(connect-syntaxes x var actual?)))
|
||||
binders))
|
||||
|
||||
(when (and unused requires)
|
||||
|
|
@ -1946,17 +1932,15 @@ If the namespace does not, they are colored the unbound color.
|
|||
(syntax->datum req-stx))
|
||||
(when id
|
||||
(add-jump-to-definition
|
||||
source-editor-cache
|
||||
var
|
||||
id
|
||||
(get-require-filename req-path user-namespace user-directory)))
|
||||
(add-mouse-over source-editor-cache
|
||||
var
|
||||
(add-mouse-over var
|
||||
(fw:gui-utils:format-literal-label
|
||||
(string-constant cs-mouse-over-import)
|
||||
(syntax-e var)
|
||||
req-path))
|
||||
(connect-syntaxes source-editor-cache req-stx var actual?)))
|
||||
(connect-syntaxes req-stx var actual?)))
|
||||
req-stxes))))))))
|
||||
|
||||
(define (id/require-match? var id req-stx)
|
||||
|
|
@ -1992,7 +1976,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(cons mod-path (list-ref binding 3))]))))
|
||||
|
||||
;; color/connect-top : namespace directory id-set syntax -> void
|
||||
(define (color/connect-top source-editor-cache rename-ht user-namespace user-directory binders var)
|
||||
(define (color/connect-top rename-ht user-namespace user-directory binders var)
|
||||
(let ([top-bound?
|
||||
(or (get-ids binders var)
|
||||
(parameterize ([current-namespace user-namespace])
|
||||
|
|
@ -2000,12 +1984,12 @@ If the namespace does not, they are colored the unbound color.
|
|||
(namespace-variable-value (syntax-e var) #t (λ () (k #f)))
|
||||
#t)))])
|
||||
(if top-bound?
|
||||
(color source-editor-cache var lexically-bound-variable-style-name)
|
||||
(color source-editor-cache var error-style-name))
|
||||
(connect-identifier source-editor-cache var rename-ht binders #f #f identifier-binding user-namespace user-directory #t)))
|
||||
(color var lexically-bound-variable-style-name)
|
||||
(color var error-style-name))
|
||||
(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
|
||||
(define (color-variable source-editor-cache var get-binding)
|
||||
(define (color-variable var get-binding)
|
||||
(let* ([b (get-binding var)]
|
||||
[lexical?
|
||||
(or (not b)
|
||||
|
|
@ -2017,8 +2001,8 @@ If the namespace does not, they are colored the unbound color.
|
|||
(and (not a)
|
||||
(not b)))))))])
|
||||
(cond
|
||||
[lexical? (color source-editor-cache var lexically-bound-variable-style-name)]
|
||||
[(pair? b) (color source-editor-cache var imported-variable-style-name)])))
|
||||
[lexical? (color var lexically-bound-variable-style-name)]
|
||||
[(pair? b) (color var imported-variable-style-name)])))
|
||||
|
||||
;; add-var : hash-table -> syntax -> void
|
||||
;; adds the variable to the hash table.
|
||||
|
|
@ -2030,9 +2014,9 @@ If the namespace does not, they are colored the unbound color.
|
|||
|
||||
;; connect-syntaxes : syntax[original] syntax[original] boolean -> void
|
||||
;; adds an arrow from `from' to `to', unless they have the same source loc.
|
||||
(define (connect-syntaxes source-editor-cache from to actual?)
|
||||
(let ([from-source (find-source-editor source-editor-cache from)]
|
||||
[to-source (find-source-editor source-editor-cache to)]
|
||||
(define (connect-syntaxes from to actual?)
|
||||
(let ([from-source (find-source-editor from)]
|
||||
[to-source (find-source-editor to)]
|
||||
[defs-text (get-defs-text)])
|
||||
(when (and from-source to-source defs-text)
|
||||
(let ([pos-from (syntax-position from)]
|
||||
|
|
@ -2050,11 +2034,11 @@ If the namespace does not, they are colored the unbound color.
|
|||
to-source to-pos-left to-pos-right
|
||||
actual?))))))))
|
||||
|
||||
;; add-mouse-over : hash-table[source-editor-cache] syntax[original] string -> void
|
||||
;; add-mouse-over : syntax[original] string -> void
|
||||
;; registers the range in the editor so that a mouse over
|
||||
;; this area shows up in the status line.
|
||||
(define (add-mouse-over source-editor-cache stx str)
|
||||
(let* ([source (find-source-editor source-editor-cache stx)]
|
||||
(define (add-mouse-over stx str)
|
||||
(let* ([source (find-source-editor stx)]
|
||||
[defs-text (get-defs-text)])
|
||||
(when (and defs-text
|
||||
source
|
||||
|
|
@ -2065,12 +2049,12 @@ If the namespace does not, they are colored the unbound color.
|
|||
(send defs-text syncheck:add-mouse-over-status
|
||||
source pos-left pos-right str)))))
|
||||
|
||||
;; add-jump-to-definition : hash-table[source-editor-cache] syntax symbol path -> void
|
||||
;; 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 source-editor-cache stx id filename)
|
||||
(let ([source (find-source-editor source-editor-cache stx)]
|
||||
(define (add-jump-to-definition stx id filename)
|
||||
(let ([source (find-source-editor stx)]
|
||||
[defs-text (get-defs-text)])
|
||||
(when (and source
|
||||
defs-text
|
||||
|
|
@ -2117,13 +2101,13 @@ If the namespace does not, they are colored the unbound color.
|
|||
orig-stx
|
||||
(λ () null)))))
|
||||
|
||||
;; annotate-require-open : hash-table[source-editor-cache] namespace string -> (stx -> void)
|
||||
;; 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 source-editor-cache user-namespace user-directory)
|
||||
(define (annotate-require-open user-namespace user-directory)
|
||||
(λ (require-spec)
|
||||
(when (syntax-original? require-spec)
|
||||
(let ([source (find-source-editor source-editor-cache require-spec)])
|
||||
(let ([source (find-source-editor require-spec)])
|
||||
(when (and (is-a? source text%)
|
||||
(syntax-position require-spec)
|
||||
(syntax-span require-spec))
|
||||
|
|
@ -2270,7 +2254,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(add-id id-map f-stx))))))
|
||||
|
||||
;; color-internal-structure : syntax str -> void
|
||||
(define (color-internal-structure source-editor-cache stx style-name)
|
||||
(define (color-internal-structure stx style-name)
|
||||
(let ([ht (make-hasheq)])
|
||||
;; ht : stx -o> true
|
||||
;; indicates if we've seen this syntax object before
|
||||
|
|
@ -2285,7 +2269,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(loop (cdr stx) (cdr datum))]
|
||||
[(syntax? stx)
|
||||
(when (syntax-original? stx)
|
||||
(color source-editor-cache stx style-name))
|
||||
(color stx style-name))
|
||||
(let ([stx-e (syntax-e stx)])
|
||||
(cond
|
||||
[(cons? stx-e)
|
||||
|
|
@ -2301,9 +2285,9 @@ If the namespace does not, they are colored the unbound color.
|
|||
(loop (unbox stx-e) (unbox datum))]
|
||||
[else (void)]))])))))
|
||||
|
||||
;; jump-to : hash-table[source-editor-cache] syntax -> void
|
||||
(define (jump-to source-editor-cache stx)
|
||||
(let ([src (find-source-editor source-editor-cache stx)]
|
||||
;; jump-to : syntax -> void
|
||||
(define (jump-to stx)
|
||||
(let ([src (find-source-editor stx)]
|
||||
[pos (syntax-position stx)]
|
||||
[span (syntax-span stx)])
|
||||
(when (and (is-a? src text%)
|
||||
|
|
@ -2313,8 +2297,8 @@ If the namespace does not, they are colored the unbound color.
|
|||
|
||||
;; color : syntax[original] str -> void
|
||||
;; colors the syntax with style-name's style
|
||||
(define (color source-editor-cache stx style-name)
|
||||
(let ([source (find-source-editor source-editor-cache stx)])
|
||||
(define (color stx style-name)
|
||||
(let ([source (find-source-editor stx)])
|
||||
(when (and (is-a? source text%)
|
||||
(syntax-position stx)
|
||||
(syntax-span stx))
|
||||
|
|
@ -2332,20 +2316,20 @@ If the namespace does not, they are colored the unbound color.
|
|||
(send source change-style style start finish #f)))
|
||||
|
||||
;; hash-table[syntax -o> (listof syntax)] -> void
|
||||
(define (add-tail-ht-links source-editor-cache tail-ht)
|
||||
(define (add-tail-ht-links tail-ht)
|
||||
(begin
|
||||
(collapse-tail-links source-editor-cache tail-ht)
|
||||
(collapse-tail-links tail-ht)
|
||||
(hash-for-each
|
||||
tail-ht
|
||||
(λ (stx-from stx-tos)
|
||||
(for-each (λ (stx-to) (add-tail-ht-link source-editor-cache stx-from stx-to))
|
||||
(for-each (λ (stx-to) (add-tail-ht-link stx-from stx-to))
|
||||
stx-tos)))))
|
||||
|
||||
;; hash-table[syntax -o> (listof syntax)] -> void
|
||||
;; take something like a transitive closure, except
|
||||
;; only when there are non-original links in between
|
||||
|
||||
(define (collapse-tail-links source-editor-cache tail-ht)
|
||||
(define (collapse-tail-links tail-ht)
|
||||
(let loop ()
|
||||
(let ([found-one? #f])
|
||||
(hash-for-each
|
||||
|
|
@ -2356,8 +2340,8 @@ If the namespace does not, they are colored the unbound color.
|
|||
(let ([stx-to-tos (hash-ref tail-ht stx-to '())])
|
||||
(for-each
|
||||
(λ (stx-to-to)
|
||||
(unless (and (add-tail-link? source-editor-cache stx-from stx-to)
|
||||
(add-tail-link? source-editor-cache stx-to stx-to-to))
|
||||
(unless (and (add-tail-link? stx-from stx-to)
|
||||
(add-tail-link? stx-to stx-to-to))
|
||||
(unless (memq stx-to-to (hash-ref tail-ht stx-from '()))
|
||||
(set! found-one? #t)
|
||||
(hash-cons! tail-ht stx-from stx-to-to))))
|
||||
|
|
@ -2376,9 +2360,9 @@ If the namespace does not, they are colored the unbound color.
|
|||
(loop)))))
|
||||
|
||||
;; add-tail-ht-link : syntax syntax -> void
|
||||
(define (add-tail-ht-link source-editor-cache from-stx to-stx)
|
||||
(let* ([to-src (find-source-editor source-editor-cache to-stx)]
|
||||
[from-src (find-source-editor source-editor-cache from-stx)]
|
||||
(define (add-tail-ht-link from-stx to-stx)
|
||||
(let* ([to-src (find-source-editor to-stx)]
|
||||
[from-src (find-source-editor from-stx)]
|
||||
[defs-text (get-defs-text)])
|
||||
(when (and to-src from-src defs-text)
|
||||
(let ([from-pos (syntax-position from-stx)]
|
||||
|
|
@ -2389,9 +2373,9 @@ If the namespace does not, they are colored the unbound color.
|
|||
to-src (- to-pos 1)))))))
|
||||
|
||||
;; add-tail-link? : syntax syntax -> boolean
|
||||
(define (add-tail-link? source-editor-cache from-stx to-stx)
|
||||
(let* ([to-src (find-source-editor source-editor-cache to-stx)]
|
||||
[from-src (find-source-editor source-editor-cache from-stx)]
|
||||
(define (add-tail-link? from-stx to-stx)
|
||||
(let* ([to-src (find-source-editor to-stx)]
|
||||
[from-src (find-source-editor from-stx)]
|
||||
[defs-text (get-defs-text)])
|
||||
(and to-src from-src defs-text
|
||||
(let ([from-pos (syntax-position from-stx)]
|
||||
|
|
@ -2414,27 +2398,24 @@ If the namespace does not, they are colored the unbound color.
|
|||
(loop (send enclosing-snip-admin get-editor)))
|
||||
ed))))
|
||||
|
||||
;; find-source-editor : cache stx -> editor or false
|
||||
(define (find-source-editor source-editor-cache stx)
|
||||
;; find-source-editor : stx -> editor or false
|
||||
(define (find-source-editor stx)
|
||||
(let ([defs-text (get-defs-text)])
|
||||
(and defs-text
|
||||
(find-source-editor/defs source-editor-cache stx defs-text))))
|
||||
(find-source-editor/defs stx defs-text))))
|
||||
|
||||
;; find-source-editor : cache stx text -> editor or false
|
||||
(define (find-source-editor/defs source-editor-cache stx defs-text)
|
||||
;; find-source-editor : stx text -> editor or false
|
||||
(define (find-source-editor/defs stx defs-text)
|
||||
(cond
|
||||
[(not (syntax-source stx)) #f]
|
||||
[(and (symbol? (syntax-source stx))
|
||||
(text:lookup-port-name (syntax-source stx)))
|
||||
=> values]
|
||||
[else
|
||||
(let txt-loop ([text defs-text])
|
||||
(cond
|
||||
[(and (is-a? text fw:text:basic<%>)
|
||||
(eq? (hash-ref source-editor-cache text #f)
|
||||
(syntax-source stx)))
|
||||
text]
|
||||
[(and (is-a? text fw:text:basic<%>)
|
||||
(or (eq? text (syntax-source stx))
|
||||
(send text port-name-matches? (syntax-source stx))))
|
||||
(hash-set! source-editor-cache text (syntax-source stx))
|
||||
(send text port-name-matches? (syntax-source stx)))
|
||||
text]
|
||||
[else
|
||||
(let snip-loop ([snip (send text find-first-snip)])
|
||||
|
|
@ -2533,11 +2514,11 @@ If the namespace does not, they are colored the unbound color.
|
|||
|
||||
|
||||
;; make-rename-menu : (cons stx[original,id] (listof stx[original,id])) (listof id-set) -> void
|
||||
(define (make-rename-menu source-editor-cache stxs id-sets)
|
||||
(define (make-rename-menu stxs id-sets)
|
||||
(let ([defs-text (currently-processing-definitions-text)])
|
||||
(when defs-text
|
||||
(let* ([source (syntax-source (car stxs))] ;; all stxs in the list must have the same source
|
||||
[source-editor (find-source-editor source-editor-cache (car stxs))])
|
||||
[source-editor (find-source-editor (car stxs))])
|
||||
(when (is-a? source-editor text%)
|
||||
(let* ([start (- (syntax-position (car stxs)) 1)]
|
||||
[fin (+ start (syntax-span (car stxs)))])
|
||||
|
|
@ -2554,8 +2535,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(callback
|
||||
(λ (x y)
|
||||
(let ([frame-parent (find-menu-parent menu)])
|
||||
(rename-callback source-editor-cache
|
||||
name-to-offer
|
||||
(rename-callback name-to-offer
|
||||
defs-text
|
||||
stxs
|
||||
id-sets
|
||||
|
|
@ -2586,7 +2566,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
;; (union #f (is-a?/c top-level-window<%>))
|
||||
;; -> void
|
||||
;; callback for the rename popup menu item
|
||||
(define (rename-callback source-editor-cache name-to-offer defs-text stxs id-sets parent)
|
||||
(define (rename-callback name-to-offer defs-text stxs id-sets parent)
|
||||
(let ([new-str
|
||||
(fw:keymap:call/text-keymap-initializer
|
||||
(λ ()
|
||||
|
|
@ -2627,7 +2607,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
(let ([txts (list defs-text)])
|
||||
(send defs-text begin-edit-sequence)
|
||||
(for-each (λ (stx)
|
||||
(let ([source-editor (find-source-editor/defs source-editor-cache stx defs-text)])
|
||||
(let ([source-editor (find-source-editor/defs stx defs-text)])
|
||||
(when (is-a? source-editor text%)
|
||||
(unless (memq source-editor txts)
|
||||
(send source-editor begin-edit-sequence)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user