suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

initial Scribble search support

Browse Source 
svn: r7738

original commit: 3ca803a6de8ff8d096cfbd968adcbe32b5ba8aaf
This commit is contained in:
Matthew Flatt 2007-11-15 17:35:02 +00:00
parent 8660e0cb98
commit c6ee14bc8e
8 changed files with 236 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/scribble/base-render.ss
View File

@ -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)

3
collects/scribble/basic.ss
View File

@ -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)])

6
collects/scribble/decode-struct.ss Normal file
View File

@ -0,0 +1,6 @@
#lang scheme/base
(require "struct.ss")
(provide-structs
[part-index-desc ()])

11
collects/scribble/decode.ss
View File

@ -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))

18
collects/scribble/manual-struct.ss Normal file
View File

@ -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) ()])

82
collects/scribble/manual.ss
View File

@ -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

35
collects/scribble/struct.ss
View File

@ -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

95
collects/setup/scribble-index.ss Normal file
View File

@ -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))))