a122ea725d
the state that online check syntax uses (indirectly via scribble) to lookup documentation. since the kill-safe abstraction moved some computation over to another thread, the values of various parameters (current-directory in this case) were not preserved. So when scribble then ended up resolving a module path with the wrong current directory, this bad value got cached. Then later, when check syntax tries to figure out what file to open to jump to it, it got the cached bogus value (even though current-directory was right when check syntax asked for the filename). closes PR 12538
56 lines
2.0 KiB
Racket
56 lines
2.0 KiB
Racket
#lang racket/base
|
|
(require setup/xref
|
|
racket/promise
|
|
scribble/xref
|
|
scribble/manual-struct)
|
|
(provide get-index-entry-info)
|
|
|
|
(define delayed-xref
|
|
(if (getenv "PLTDRXREFDELAY")
|
|
(begin
|
|
(printf "PLTDRXREFDELAY: using plain delay\n")
|
|
(delay (begin
|
|
(printf "PLTDRXREFDELAY: loading xref\n")
|
|
(begin0
|
|
(load-collections-xref)
|
|
(printf "PLTDRXREFDELAY: loaded xref\n")))))
|
|
(delay/idle (load-collections-xref))))
|
|
|
|
(define req-chan (make-channel))
|
|
|
|
(define thd
|
|
(thread
|
|
(λ ()
|
|
(let loop ()
|
|
(define-values (binding-info cd resp-chan nack-evt) (apply values (channel-get req-chan)))
|
|
(define resp
|
|
(parameterize ([current-directory cd])
|
|
(define xref (force delayed-xref))
|
|
(and xref
|
|
(let ([definition-tag (xref-binding->definition-tag xref binding-info #f)])
|
|
(and definition-tag
|
|
(let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)])
|
|
(and path
|
|
(let ([index-entry (xref-tag->index-entry xref definition-tag)])
|
|
(and index-entry
|
|
(list (entry-desc index-entry)
|
|
path
|
|
tag))))))))))
|
|
(thread
|
|
(λ ()
|
|
(sync (channel-put-evt resp-chan resp)
|
|
nack-evt)))
|
|
(loop)))))
|
|
|
|
;; this function is called from a thread that might be killed
|
|
;; (but the body of this module is run in a context where it is
|
|
;; guaranteed that that custodian doesn't get shut down)
|
|
(define (get-index-entry-info binding-info)
|
|
(and (not (thread-dead? thd))
|
|
(sync
|
|
(nack-guard-evt
|
|
(λ (nack-evt)
|
|
(define resp-chan (make-channel))
|
|
(channel-put req-chan (list binding-info (current-directory) resp-chan nack-evt))
|
|
resp-chan)))))
|