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

fixed PR 9107

Browse Source 
svn: r8013
This commit is contained in:
Robby Findler 2007-12-14 22:58:31 +00:00
parent 58ffe9133e
commit 553d628491
1 changed files with 33 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
collects/drscheme/syncheck.ss
View File

@ -2368,36 +2368,39 @@ If the namespace does not, they are colored the unbound color.
;; document-variable : stx identifier-binding -> void ;; document-variable : stx identifier-binding -> void
(define (document-variable stx get-binding) (define (document-variable stx get-binding)
(let ([defs-frame (currently-processing-drscheme-frame)]) (when (syntax-original? stx)
(when defs-frame (let ([defs-frame (currently-processing-drscheme-frame)])
(let* ([defs-text (send defs-frame get-definitions-text)] (when defs-frame
[binding-info (get-binding stx)]) (let* ([defs-text (send defs-frame get-definitions-text)]
(when (pair? binding-info) [binding-info (get-binding stx)])
(let* ([start (- (syntax-position stx) 1)] (when (and (pair? binding-info)
[fin (+ start (syntax-span stx))] (syntax-position stx)
[source-mod (list-ref binding-info 0)] (syntax-span stx))
[source-id (list-ref binding-info 1)] (let* ([start (- (syntax-position stx) 1)]
[definition-tag (xref-binding->definition-tag (get-xref) source-mod source-id)]) [fin (+ start (syntax-span stx))]
(when definition-tag [source-mod (list-ref binding-info 0)]
(let-values ([(path tag) (xref-tag->path+anchor (get-xref) definition-tag)]) [source-id (list-ref binding-info 1)]
(when path [definition-tag (xref-binding->definition-tag (get-xref) source-mod source-id)])
(send defs-text syncheck:add-background-color defs-text "navajowhite" start fin (syntax-e stx)) (when definition-tag
(send defs-text syncheck:add-menu (let-values ([(path tag) (xref-tag->path+anchor (get-xref) definition-tag)])
defs-text (when path
start (send defs-text syncheck:add-background-color defs-text "navajowhite" start fin (syntax-e stx))
fin (send defs-text syncheck:add-menu
(syntax-e stx) defs-text
(λ (menu) start
(instantiate menu-item% () fin
(parent menu) (syntax-e stx)
(label (format (string-constant cs-view-docs) source-id)) (λ (menu)
(callback (instantiate menu-item% ()
(λ (x y) (parent menu)
(send-url (format "file://~a~a" (label (format (string-constant cs-view-docs) source-id))
(path->string path) (callback
(if tag (λ (x y)
(string-append "#" (uri-encode tag)) (send-url (format "file://~a~a"
""))))))))))))))))) (path->string path)
(if tag
(string-append "#" (uri-encode tag))
""))))))))))))))))))