diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss index eb2154c3..1b29a0bc 100644 --- a/collects/scribble/base-render.ss +++ b/collects/scribble/base-render.ss @@ -54,6 +54,12 @@ (define/public (get-undefined ri) (hash-table-map (resolve-info-undef ri) (lambda (k v) k))) + + (define/public (transfer-info ci src-ci) + (let ([in-ht (collect-info-ext-ht ci)]) + (hash-table-for-each (collect-info-ext-ht src-ci) + (lambda (k v) + (hash-table-put! in-ht k v))))) ;; ---------------------------------------- ;; global-info collection @@ -193,7 +199,8 @@ (collect-put! ci `(index-entry ,(generate-tag (index-element-tag i) ci)) (list (index-element-plain-seq i) - (index-element-entry-seq i)))) + (index-element-entry-seq i) + (index-element-desc i)))) ;; ---------------------------------------- ;; global-info resolution @@ -269,6 +276,11 @@ d ri)] [(element? i) (cond + [(index-element? i) + (let ([e (index-element-desc i)]) + (when (delayed-index-desc? e) + (let ([v ((delayed-index-desc-resolve e) this d ri)]) + (hash-table-put! (resolve-info-delays ri) e v))))] [(link-element? i) (resolve-get d ri (link-element-tag i))]) (for-each (lambda (e) diff --git a/collects/scribble/basic.ss b/collects/scribble/basic.ss index b7664504..9ff87fcb 100644 --- a/collects/scribble/basic.ss +++ b/collects/scribble/basic.ss @@ -167,7 +167,8 @@ (list (make-target-element #f content `(idx ,tag))) `(idx ,tag) word-seq - element-seq)) + element-seq + #f)) (define (index* word-seq content-seq . s) (let ([key (make-generated-tag)]) diff --git a/collects/scribble/decode-struct.ss b/collects/scribble/decode-struct.ss new file mode 100644 index 00000000..48ef06f3 --- /dev/null +++ b/collects/scribble/decode-struct.ss @@ -0,0 +1,6 @@ +#lang scheme/base + +(require "struct.ss") + +(provide-structs + [part-index-desc ()]) diff --git a/collects/scribble/decode.ss b/collects/scribble/decode.ss index e4a78e9d..af2affd3 100644 --- a/collects/scribble/decode.ss +++ b/collects/scribble/decode.ss @@ -1,6 +1,7 @@ (module decode mzscheme (require "struct.ss" + "decode-struct.ss" (lib "contract.ss") (lib "class.ss")) @@ -75,17 +76,21 @@ null tag (part-index-decl-plain-seq k) - (part-index-decl-entry-seq k))) + (part-index-decl-entry-seq k) + #f)) keys k-tags)]) (append - (if title + (if (and title (not (or (eq? 'hidden style) + (and (list? style) + (memq 'hidden style))))) (cons (make-index-element #f null (car tags) (list (regexp-replace #px"^(?:A|An|The)\\s" (content->string title) "")) - (list (make-element #f title))) + (list (make-element #f title)) + (make-part-index-desc)) l) l) colls)) diff --git a/collects/scribble/manual-struct.ss b/collects/scribble/manual-struct.ss new file mode 100644 index 00000000..6722bafd --- /dev/null +++ b/collects/scribble/manual-struct.ss @@ -0,0 +1,18 @@ +#lang scheme/base + +(require "struct.ss" + scheme/contract) + +(provide-structs + [exported-index-desc ([name symbol?] + [from-libs (listof module-path?)])] + [(method-index-desc exported-index-desc) ([method-name symbol?])] + [(procedure-index-desc exported-index-desc) ()] + [(thing-index-desc exported-index-desc) ()] + [(struct-index-desc exported-index-desc) ()] + [(form-index-desc exported-index-desc) ()] + [(class-index-desc exported-index-desc) ()] + [(interface-index-desc exported-index-desc) ()]) + + + diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index 39dc7360..35d480bd 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -5,6 +5,7 @@ "scheme.ss" "config.ss" "basic.ss" + "manual-struct.ss" mzlib/string scheme/class scheme/stxparam @@ -281,7 +282,8 @@ (list t) (target-element-tag t) (list (element->string e)) - (list e)))) + (list e) + 'tech))) (define (tech #:doc [doc #f] . s) (*tech make-link-element "techlink" doc s)) @@ -591,6 +593,15 @@ (lambda () e) (lambda () e))) + (define (get-exporting-libraries render p ri) + (resolve-get/tentative p ri '(exporting-libraries #f))) + + (define (with-exporting-libraries proc) + (make-delayed-index-desc + (lambda (render part ri) + (proc + (or (get-exporting-libraries render part ri) null))))) + (define (*defproc mode within-id stx-ids prototypes arg-contractss result-contracts content-thunk) (let ([spacer (hspace 1)] @@ -696,7 +707,13 @@ content tag (list (symbol->string mname)) - content)) + content + (with-exporting-libraries + (lambda (libs) + (make-method-index-desc + (syntax-e within-id) + libs + mname))))) tag) (car content))) (*method (car prototype) within-id))))] @@ -714,7 +731,12 @@ content tag (list (symbol->string (car prototype))) - content)) + content + (with-exporting-libraries + (lambda (libs) + (make-procedure-index-desc + (car prototype) + libs))))) tag) (car content))) (annote-exporting-library @@ -904,7 +926,7 @@ stx-id (let* ([name (apply string-append - (map symbol->string (car wrappers)))] + (map symbol->string (cdar wrappers)))] [tag (register-scheme-definition (datum->syntax stx-id @@ -919,7 +941,13 @@ (list content) tag (list name) - (list (schemeidfont (make-element "schemevaluelink" (list name)))))) + (list (schemeidfont (make-element "schemevaluelink" (list name)))) + (with-exporting-libraries + (lambda (libs) + (let ([name (string->symbol name)]) + (if (eq? 'info (caar wrappers)) + (make-struct-index-desc name libs) + (make-procedure-index-desc name libs))))))) tag) content)) (cdr wrappers)))) @@ -952,12 +980,13 @@ (let ([name (if (pair? name) (car name) name)]) - (list* (list name) - (list name '?) - (list 'make- name) + (list* (list 'info name) + (list 'type 'struct: name) + (list 'predicate name '?) + (list 'constructor 'make- name) (append (map (lambda (f) - (list name '- (field-name f))) + (list 'accessor name '- (field-name f))) fields) (if immutable? null @@ -966,7 +995,7 @@ (map (lambda (f) (if (and (pair? (car f)) (memq '#:mutable (car f))) - (list 'set- name '- (field-name f) '!) + (list 'mutator 'set- name '- (field-name f) '!) #f)) fields)))))))]) (if (pair? name) @@ -1116,7 +1145,10 @@ content tag (list (symbol->string name)) - content)) + content + (with-exporting-libraries + (lambda (libs) + (make-thing-index-desc name libs))))) tag) (car content))) spacer ":" spacer @@ -1181,7 +1213,10 @@ content tag (list (symbol->string (syntax-e kw-id))) - content)) + content + (with-exporting-libraries + (lambda (libs) + (make-form-index-desc (syntax-e kw-id) libs))))) content) stag)) tag) @@ -1516,7 +1551,7 @@ (decode-flow (build-body decl (decl-body decl)))))))))) - (define (*class-doc stx-id super intfs whole-page?) + (define (*class-doc stx-id super intfs whole-page? make-index-desc) (let ([spacer (hspace 1)]) (make-table 'boxed @@ -1532,13 +1567,14 @@ make-page-target-element make-toc-target-element) #f - (if whole-page? - content ; title is already an index entry - (list (make-index-element #f - content - tag - (list (symbol->string (syntax-e stx-id))) - content))) + (list (make-index-element #f + content + tag + (list (symbol->string (syntax-e stx-id))) + content + (with-exporting-libraries + (lambda (libs) + (make-index-desc (syntax-e stx-id) libs))))) tag) (car content))) spacer ":" spacer @@ -1583,7 +1619,8 @@ (*class-doc (quote-syntax/loc name) (quote-syntax super) (list (quote-syntax intf) ...) - whole-page?))) + whole-page? + make-class-index-desc))) (list body ...))))])) (define-syntax defclass @@ -1609,7 +1646,8 @@ (*class-doc (quote-syntax/loc name) #f (list (quote-syntax intf) ...) - whole-page?))) + whole-page? + make-interface-index-desc))) (list body ...))))])) (define-syntax definterface diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss index 800125a2..3b7bdb15 100644 --- a/collects/scribble/struct.ss +++ b/collects/scribble/struct.ss @@ -136,7 +136,8 @@ [(link-element element) ([tag tag?])] [(index-element element) ([tag tag?] [plain-seq (listof string?)] - [entry-seq list?])] + [entry-seq list?] + [desc any/c])] [(aux-element element) ()] [(hover-element element) ([text string?])] ;; specific renders support other elements, especially strings @@ -194,6 +195,38 @@ ;; ---------------------------------------- + ;; Delayed index entry also has special serialization support. + ;; It uses the same delay -> value table as delayed-element + (define-struct delayed-index-desc (resolve) + #:mutable + #:property + prop:serializable + (make-serialize-info + (lambda (d) + (let ([ri (current-serialize-resolve-info)]) + (unless ri + (error 'serialize-delayed-index-desc + "current-serialize-resolve-info not set")) + (with-handlers ([exn:fail:contract? + (lambda (exn) + (error 'serialize-index-desc + "serialization failed (wrong resolve info?); ~a" + (exn-message exn)))]) + (vector + (delayed-element-content d ri))))) + #'deserialize-delayed-index-desc + #f + (or (current-load-relative-directory) (current-directory)))) + + (provide/contract + (struct delayed-index-desc ([resolve (any/c part? resolve-info? . -> . any)]))) + + (provide deserialize-delayed-index-desc) + (define deserialize-delayed-index-desc + (make-deserialize-info values values)) + + ;; ---------------------------------------- + (define-struct (collect-element element) (collect) #:mutable #:property diff --git a/collects/setup/scribble-index.ss b/collects/setup/scribble-index.ss new file mode 100644 index 00000000..c635a6bb --- /dev/null +++ b/collects/setup/scribble-index.ss @@ -0,0 +1,95 @@ +#lang scheme/base + +(require scribble/struct + scribble/manual-struct + scribble/decode-struct + scribble/base-render + (prefix-in html: scribble/html-render) + scheme/class + setup/getinfo + setup/dirs + syntax/namespace-reflect + mzlib/serialize + scheme/file) + +(provide load-xref + xref-render + xref-index + (struct-out entry)) + +(define-struct entry (words content link-key desc)) +(define-struct xrefs (renderer ri)) + +;; ---------------------------------------- +;; Xref loading + +(define-struct doc (source dest)) + +(define-reflection-anchor here) + +(define (load-xref) + (let* ([renderer (new (html:render-mixin render%) + [dest-dir (find-system-path 'temp-dir)])] + [dirs (find-relevant-directories '(scribblings))] + [infos (map get-info/full dirs)] + [docs (filter + values + (apply append + (map (lambda (i dir) + (let ([s (i 'scribblings)]) + (map (lambda (d) + (if (pair? d) + (let ([flags (if (pair? (cdr d)) + (cadr d) + null)]) + (let ([name (if (and (pair? (cdr d)) + (pair? (cddr d)) + (caddr d)) + (cadr d) + (let-values ([(base name dir?) (split-path (car d))]) + (path-replace-suffix name #"")))]) + (make-doc + (build-path dir (car d)) + (if (memq 'main-doc flags) + (build-path (find-doc-dir) name) + (build-path dir "compiled" "doc" name))))) + #f)) + s))) + infos + dirs)))] + [ci (send renderer collect null null)]) + (map (lambda (doc) + (parameterize ([current-namespace (reflection-anchor->namespace here)]) + (with-handlers ([exn:fail? (lambda (exn) exn)]) + (let ([r (with-input-from-file (build-path (doc-dest doc) "xref-out.ss") + read)]) + (send renderer deserialize-info (cadr r) ci))))) + docs) + (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))))