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

check syntax now (silently) copes with an exception raised by the documentation xref loading

Browse Source 
svn: r8439
This commit is contained in:
Robby Findler 2008-01-28 02:11:31 +00:00
parent d49f16da7f
commit eda72235bd
1 changed files with 41 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/drscheme/syncheck.ss
View File

@ -95,13 +95,23 @@ If the namespace does not, they are colored the unbound color.
(define xref 'not-yet-loaded-xref) (define xref 'not-yet-loaded-xref)
(define (get-xref) (define (get-xref)
(when (symbol? xref) (cond
(error 'get-xref "xref has not yet been loaded")) [(equal? xref 'failed-to-load) #f]
xref) [else
(when (symbol? xref)
(error 'get-xref "xref has not yet been loaded"))
xref]))
(define (force-xref th) (define (force-xref th)
(when (symbol? xref) (cond
(th) [(equal? xref 'failed-to-load)
(set! xref (load-collections-xref)))) (void)]
[(symbol? xref)
(th)
(with-handlers ((exn? (λ (exn) (set! xref 'failed-to-load))))
(set! xref (load-collections-xref)))]
[else
(void)]))
;;; ;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;;
@ -2382,29 +2392,31 @@ If the namespace does not, they are colored the unbound color.
(syntax-span stx)) (syntax-span stx))
(let* ([start (- (syntax-position stx) 1)] (let* ([start (- (syntax-position stx) 1)]
[fin (+ start (syntax-span stx))] [fin (+ start (syntax-span stx))]
[definition-tag (xref-binding->definition-tag (get-xref) binding-info #f)]) [xref (get-xref)])
(when definition-tag (when xref
(let-values ([(path tag) (xref-tag->path+anchor (get-xref) definition-tag)]) (let ([definition-tag (xref-binding->definition-tag xref binding-info #f)])
(when path (when definition-tag
(let ([index-entry (xref-tag->index-entry (get-xref) definition-tag)]) (let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)])
(when index-entry (when path
(send defs-text syncheck:add-background-color defs-text "navajowhite" start fin (syntax-e stx)) (let ([index-entry (xref-tag->index-entry xref definition-tag)])
(send defs-text syncheck:add-menu (when index-entry
defs-text (send defs-text syncheck:add-background-color defs-text "navajowhite" start fin (syntax-e stx))
start (send defs-text syncheck:add-menu
fin defs-text
(syntax-e stx) start
(λ (menu) fin
(instantiate menu-item% () (syntax-e stx)
(parent menu) (λ (menu)
(label (fw:gui-utils:format-literal-label (string-constant cs-view-docs) (exported-index-desc-name (entry-desc index-entry)))) (instantiate menu-item% ()
(callback (parent menu)
(λ (x y) (label (fw:gui-utils:format-literal-label (string-constant cs-view-docs) (exported-index-desc-name (entry-desc index-entry))))
(send-url (format "file://~a~a" (callback
(path->string path) (λ (x y)
(if tag (send-url (format "file://~a~a"
(string-append "#" (uri-encode tag)) (path->string path)
"")))))))))))))))))))) (if tag
(string-append "#" (uri-encode tag))
""))))))))))))))))))))))