0c6734f782
corner of the definitions window, based on the information that check
syntax computes
This commit contains two separate changes to make this work:
- adding a new renderer, based on the text renderer, that
pulls out the contents of the blue boxes and saves them
in the doc/ directories (specifically in the files named
contract-blueboxes.rktd)
- extend check syntax to use and display the information
build by the new renderer
57 lines
2.0 KiB
Racket
57 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
|
|
definition-tag
|
|
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)))))
|