121 lines
4.3 KiB
Scheme
121 lines
4.3 KiB
Scheme
#lang scheme/base
|
|
|
|
(require scribble/struct
|
|
scribble/manual-struct
|
|
scribble/decode-struct
|
|
scribble/base-render
|
|
(prefix-in html: scribble/html-render)
|
|
scheme/class
|
|
mzlib/serialize
|
|
scheme/path
|
|
setup/main-collects)
|
|
|
|
(provide load-xref
|
|
xref?
|
|
xref-render
|
|
xref-index
|
|
xref-binding->definition-tag
|
|
xref-tag->path+anchor
|
|
(struct-out entry))
|
|
|
|
(define-struct entry (words ; list of strings: main term, sub-term, etc.
|
|
content ; Scribble content to the index label
|
|
link-key ; for generating a Scribble link
|
|
desc)) ; further info that depends on the kind of index entry
|
|
|
|
;; Private:
|
|
(define-struct xrefs (renderer ri))
|
|
|
|
(define (xref? x) (xrefs? x))
|
|
|
|
;; ----------------------------------------
|
|
;; Xref loading
|
|
|
|
(define-namespace-anchor here)
|
|
|
|
(define (load-xref sources)
|
|
(let* ([renderer (new (html:render-mixin render%)
|
|
[dest-dir (find-system-path 'temp-dir)])]
|
|
[ci (send renderer collect null null)])
|
|
(for-each (lambda (src)
|
|
(parameterize ([current-namespace (namespace-anchor->empty-namespace here)])
|
|
(let ([r (with-input-from-file src read)])
|
|
(send renderer deserialize-info (cadr r) ci))))
|
|
sources)
|
|
(make-xrefs renderer (send renderer resolve null null ci))))
|
|
|
|
;; ----------------------------------------
|
|
;; Xref reading
|
|
|
|
(define (xref-index xrefs)
|
|
(filter
|
|
values
|
|
(hash-table-map (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))
|
|
(lambda (k v)
|
|
(and (pair? k)
|
|
(eq? (car k) 'index-entry)
|
|
(make-entry (car v)
|
|
(cadr v)
|
|
(cadr k)
|
|
(caddr v)))))))
|
|
|
|
(define (xref-render xrefs doc dest-file)
|
|
(let* ([dest-file (if (string? dest-file)
|
|
(string->path dest-file)
|
|
dest-file)]
|
|
[renderer (new (html:render-mixin render%)
|
|
[dest-dir (path-only dest-file)])]
|
|
[ci (send renderer collect (list doc) (list dest-file))])
|
|
(send renderer transfer-info ci (resolve-info-ci (xrefs-ri xrefs)))
|
|
(let ([ri (send renderer resolve (list doc) (list dest-file) ci)])
|
|
(send renderer render (list doc) (list dest-file) ri)
|
|
(void))))
|
|
|
|
;; Returns (values <tag-or-#f> <form?>)
|
|
(define (xref-binding-tag xrefs src id)
|
|
(let ([search
|
|
(lambda (src)
|
|
(let ([base (format ":~a:~a"
|
|
(if (path? src)
|
|
(path->main-collects-relative src)
|
|
src)
|
|
id)]
|
|
[ht (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))])
|
|
(let ([form-tag `(form ,base)]
|
|
[val-tag `(def ,base)])
|
|
(if (hash-table-get ht form-tag #f)
|
|
(values form-tag #t)
|
|
(if (hash-table-get ht val-tag #f)
|
|
(values val-tag #f)
|
|
(values #f #f))))))])
|
|
(let loop ([src src])
|
|
(cond
|
|
[(path? src)
|
|
(if (complete-path? src)
|
|
(search src)
|
|
(loop (path->complete-path src)))]
|
|
[(path-string? src)
|
|
(loop (path->complete-path src))]
|
|
[(resolved-module-path? src)
|
|
(let ([n (resolved-module-path-name src)])
|
|
(if (pair? n)
|
|
(loop n)
|
|
(search n)))]
|
|
[(module-path-index? src)
|
|
(loop (module-path-index-resolve src))]
|
|
[(module-path? src)
|
|
(loop (module-path-index-join src #f))]
|
|
[else
|
|
(raise-type-error 'xref-binding-definition->tag
|
|
"module path, resolved module path, module path index, path, or string"
|
|
src)]))))
|
|
|
|
(define (xref-binding->definition-tag xrefs src id)
|
|
(let-values ([(tag form?) (xref-binding-tag xrefs src id)])
|
|
tag))
|
|
|
|
(define (xref-tag->path+anchor xrefs tag)
|
|
(let ([renderer (new (html:render-mixin render%)
|
|
[dest-dir (find-system-path 'temp-dir)])])
|
|
(send renderer tag->path+anchor (xrefs-ri xrefs) tag)))
|