commit c6ee14bc8e0429ceb5984d4f60744b31342a62bd
parent 8660e0cb984131597a38fdac47e22baff14f62da
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 15 Nov 2007 17:35:02 +0000
initial Scribble search support
svn: r7738
original commit: 3ca803a6de8ff8d096cfbd968adcbe32b5ba8aaf
Diffstat:
8 files changed, 236 insertions(+), 28 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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))))
