suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

initial Scribble search support

Browse Source 
svn: r7738
This commit is contained in:
Matthew Flatt 2007-11-15 17:35:02 +00:00
parent 169ee4cbd1
commit 3ca803a6de
9 changed files with 289 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -55,6 +55,12 @@
(define/public (get-undefined ri) (define/public (get-undefined ri)
(hash-table-map (resolve-info-undef ri) (lambda (k v) k))) (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 ;; global-info collection
@ -193,7 +199,8 @@
(collect-put! ci (collect-put! ci
`(index-entry ,(generate-tag (index-element-tag i) ci)) `(index-entry ,(generate-tag (index-element-tag i) ci))
(list (index-element-plain-seq i) (list (index-element-plain-seq i)
(index-element-entry-seq i)))) (index-element-entry-seq i)
(index-element-desc i))))
;; ---------------------------------------- ;; ----------------------------------------
;; global-info resolution ;; global-info resolution
@ -269,6 +276,11 @@
d ri)] d ri)]
[(element? i) [(element? i)
(cond (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) [(link-element? i)
(resolve-get d ri (link-element-tag i))]) (resolve-get d ri (link-element-tag i))])
(for-each (lambda (e) (for-each (lambda (e)

3
collects/scribble/basic.ss
View File

@ -167,7 +167,8 @@
(list (make-target-element #f content `(idx ,tag))) (list (make-target-element #f content `(idx ,tag)))
`(idx ,tag) `(idx ,tag)
word-seq word-seq
element-seq)) element-seq
#f))
(define (index* word-seq content-seq . s) (define (index* word-seq content-seq . s)
(let ([key (make-generated-tag)]) (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 (module decode mzscheme
(require "struct.ss" (require "struct.ss"
"decode-struct.ss"
(lib "contract.ss") (lib "contract.ss")
(lib "class.ss")) (lib "class.ss"))
@ -75,17 +76,21 @@
null null
tag tag
(part-index-decl-plain-seq k) (part-index-decl-plain-seq k)
(part-index-decl-entry-seq k))) (part-index-decl-entry-seq k)
#f))
keys k-tags)]) keys k-tags)])
(append (append
(if title (if (and title (not (or (eq? 'hidden style)
(and (list? style)
(memq 'hidden style)))))
(cons (make-index-element (cons (make-index-element
#f #f
null null
(car tags) (car tags)
(list (regexp-replace #px"^(?:A|An|The)\\s" (content->string title) (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)
l) l)
colls)) 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) ()])

74
collects/scribble/manual.ss
View File

@ -5,6 +5,7 @@
"scheme.ss" "scheme.ss"
"config.ss" "config.ss"
"basic.ss" "basic.ss"
"manual-struct.ss"
mzlib/string mzlib/string
scheme/class scheme/class
scheme/stxparam scheme/stxparam
@ -281,7 +282,8 @@
(list t) (list t)
(target-element-tag t) (target-element-tag t)
(list (element->string e)) (list (element->string e))
(list e)))) (list e)
'tech)))
(define (tech #:doc [doc #f] . s) (define (tech #:doc [doc #f] . s)
(*tech make-link-element "techlink" doc s)) (*tech make-link-element "techlink" doc s))
@ -591,6 +593,15 @@
(lambda () e) (lambda () e)
(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 (define (*defproc mode within-id
stx-ids prototypes arg-contractss result-contracts content-thunk) stx-ids prototypes arg-contractss result-contracts content-thunk)
(let ([spacer (hspace 1)] (let ([spacer (hspace 1)]
@ -696,7 +707,13 @@
content content
tag tag
(list (symbol->string mname)) (list (symbol->string mname))
content)) content
(with-exporting-libraries
(lambda (libs)
(make-method-index-desc
(syntax-e within-id)
libs
mname)))))
tag) tag)
(car content))) (car content)))
(*method (car prototype) within-id))))] (*method (car prototype) within-id))))]
@ -714,7 +731,12 @@
content content
tag tag
(list (symbol->string (car prototype))) (list (symbol->string (car prototype)))
content)) content
(with-exporting-libraries
(lambda (libs)
(make-procedure-index-desc
(car prototype)
libs)))))
tag) tag)
(car content))) (car content)))
(annote-exporting-library (annote-exporting-library
@ -904,7 +926,7 @@
stx-id stx-id
(let* ([name (let* ([name
(apply string-append (apply string-append
(map symbol->string (car wrappers)))] (map symbol->string (cdar wrappers)))]
[tag [tag
(register-scheme-definition (register-scheme-definition
(datum->syntax stx-id (datum->syntax stx-id
@ -919,7 +941,13 @@
(list content) (list content)
tag tag
(list name) (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) tag)
content)) content))
(cdr wrappers)))) (cdr wrappers))))
@ -952,12 +980,13 @@
(let ([name (if (pair? name) (let ([name (if (pair? name)
(car name) (car name)
name)]) name)])
(list* (list name) (list* (list 'info name)
(list name '?) (list 'type 'struct: name)
(list 'make- name) (list 'predicate name '?)
(list 'constructor 'make- name)
(append (append
(map (lambda (f) (map (lambda (f)
(list name '- (field-name f))) (list 'accessor name '- (field-name f)))
fields) fields)
(if immutable? (if immutable?
null null
@ -966,7 +995,7 @@
(map (lambda (f) (map (lambda (f)
(if (and (pair? (car f)) (if (and (pair? (car f))
(memq '#:mutable (car f))) (memq '#:mutable (car f)))
(list 'set- name '- (field-name f) '!) (list 'mutator 'set- name '- (field-name f) '!)
#f)) #f))
fields)))))))]) fields)))))))])
(if (pair? name) (if (pair? name)
@ -1116,7 +1145,10 @@
content content
tag tag
(list (symbol->string name)) (list (symbol->string name))
content)) content
(with-exporting-libraries
(lambda (libs)
(make-thing-index-desc name libs)))))
tag) tag)
(car content))) (car content)))
spacer ":" spacer spacer ":" spacer
@ -1181,7 +1213,10 @@
content content
tag tag
(list (symbol->string (syntax-e kw-id))) (list (symbol->string (syntax-e kw-id)))
content)) content
(with-exporting-libraries
(lambda (libs)
(make-form-index-desc (syntax-e kw-id) libs)))))
content) content)
stag)) stag))
tag) tag)
@ -1516,7 +1551,7 @@
(decode-flow (decode-flow
(build-body decl (decl-body decl)))))))))) (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)]) (let ([spacer (hspace 1)])
(make-table (make-table
'boxed 'boxed
@ -1532,13 +1567,14 @@
make-page-target-element make-page-target-element
make-toc-target-element) make-toc-target-element)
#f #f
(if whole-page?
content ; title is already an index entry
(list (make-index-element #f (list (make-index-element #f
content content
tag tag
(list (symbol->string (syntax-e stx-id))) (list (symbol->string (syntax-e stx-id)))
content))) content
(with-exporting-libraries
(lambda (libs)
(make-index-desc (syntax-e stx-id) libs)))))
tag) tag)
(car content))) (car content)))
spacer ":" spacer spacer ":" spacer
@ -1583,7 +1619,8 @@
(*class-doc (quote-syntax/loc name) (*class-doc (quote-syntax/loc name)
(quote-syntax super) (quote-syntax super)
(list (quote-syntax intf) ...) (list (quote-syntax intf) ...)
whole-page?))) whole-page?
make-class-index-desc)))
(list body ...))))])) (list body ...))))]))
(define-syntax defclass (define-syntax defclass
@ -1609,7 +1646,8 @@
(*class-doc (quote-syntax/loc name) (*class-doc (quote-syntax/loc name)
#f #f
(list (quote-syntax intf) ...) (list (quote-syntax intf) ...)
whole-page?))) whole-page?
make-interface-index-desc)))
(list body ...))))])) (list body ...))))]))
(define-syntax definterface (define-syntax definterface

35
collects/scribble/struct.ss
View File

@ -136,7 +136,8 @@
[(link-element element) ([tag tag?])] [(link-element element) ([tag tag?])]
[(index-element element) ([tag tag?] [(index-element element) ([tag tag?]
[plain-seq (listof string?)] [plain-seq (listof string?)]
[entry-seq list?])] [entry-seq list?]
[desc any/c])]
[(aux-element element) ()] [(aux-element element) ()]
[(hover-element element) ([text string?])] [(hover-element element) ([text string?])]
;; specific renders support other elements, especially strings ;; 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) (define-struct (collect-element element) (collect)
#:mutable #:mutable
#:property #: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))))

90
collects/tests/mred/item.ss
View File

@ -1,4 +1,6 @@
#lang scheme/gui
(require (lib "class.ss") (require (lib "class.ss")
(lib "class100.ss") (lib "class100.ss")
(lib "etc.ss")) (lib "etc.ss"))
@ -184,7 +186,7 @@
(define OTHER-LABEL "XXXXXXXXXXXXXXXXXXXXXX") (define OTHER-LABEL "XXXXXXXXXXXXXXXXXXXXXX")
(define-values (icons-path local-path) (define-values (icons-path local-path)
(let ([d (current-load-relative-directory)]) (let ([d (this-expression-source-directory)])
(values (values
(lambda (n) (lambda (n)
(build-path (collection-path "icons") n)) (build-path (collection-path "icons") n))
@ -223,7 +225,7 @@
(send dc draw-text "Tab in" 0 60))))] (send dc draw-text "Tab in" 0 60))))]
[on-event [on-event
(lambda (e) (lambda (e)
(if (send e button-down?) (when (send e button-down?)
(let ([x (send e get-x)] (let ([x (send e get-x)]
[y (send e get-y)] [y (send e get-y)]
[m (if (or (null? last-m) [m (if (or (null? last-m)
@ -289,7 +291,7 @@
(define prev-frame #f) (define prev-frame #f)
(define bitmap% (define bitmap2%
(class100 bitmap% args (class100 bitmap% args
(inherit ok?) (inherit ok?)
(sequence (sequence
@ -298,29 +300,27 @@
(printf "bitmap failure: ~s~n" args))))) (printf "bitmap failure: ~s~n" args)))))
(define (active-mixin %) (define (active-mixin %)
(class100-asi % (class %
(private-field (define pre-on void)
[pre-on void] (define click-i void)
[click-i void] (define el void)
[el void]) (override* [on-subwindow-event (lambda args
(rename [super-on-subwindow-event on-subwindow-event]
[super-on-subwindow-char on-subwindow-char])
(override [on-subwindow-event (lambda args
(apply el args) (apply el args)
(or (apply pre-on args) (or (apply pre-on args)
(apply click-i args) (apply click-i args)
(super-on-subwindow-event . args)))] (super on-subwindow-event . args)))]
[on-subwindow-char (lambda args [on-subwindow-char (lambda args
(or (apply pre-on args) (or (apply pre-on args)
(super-on-subwindow-char . args)))] (super on-subwindow-char . args)))]
[on-activate (lambda (on?) (printf "active: ~a~n" on?))] [on-activate (lambda (on?) (printf "active: ~a~n" on?))]
[on-move (lambda (x y) (printf "moved: ~a ~a~n" x y))] [on-move (lambda (x y) (printf "moved: ~a ~a~n" x y))]
[on-size (lambda (x y) (printf "sized: ~a ~a~n" x y))]) [on-size (lambda (x y) (printf "sized: ~a ~a~n" x y))])
(public [set-info (public* [set-info
(lambda (ep) (lambda (ep)
(set! pre-on (add-pre-note this ep)) (set! pre-on (add-pre-note this ep))
(set! click-i (add-click-intercept this ep)) (set! click-i (add-click-intercept this ep))
(set! el (add-enter/leave-note this ep)))]))) (set! el (add-enter/leave-note this ep)))])
(super-new)))
(define active-frame% (active-mixin frame%)) (define active-frame% (active-mixin frame%))
(define active-dialog% (active-mixin dialog%)) (define active-dialog% (active-mixin dialog%))
@ -339,13 +339,13 @@
(apply super-init name args)))) (apply super-init name args))))
(define return-bmp (define return-bmp
(make-object bitmap% (icons-path "return.xbm") 'xbm)) (make-object bitmap2% (icons-path "return.xbm") 'xbm))
(define bb-bmp (define bb-bmp
(make-object bitmap% (icons-path "bb.gif") 'gif)) (make-object bitmap2% (icons-path "bb.gif") 'gif))
(define mred-bmp (define mred-bmp
(make-object bitmap% (icons-path "mred.xbm") 'xbm)) (make-object bitmap2% (icons-path "mred.xbm") 'xbm))
(define nruter-bmp (define nruter-bmp
(make-object bitmap% (local-path "nruter.xbm") 'xbm)) (make-object bitmap2% (local-path "nruter.xbm") 'xbm))
(define (add-label-direction label-h? l) (define (add-label-direction label-h? l)
(if (not label-h?) (if (not label-h?)
@ -1398,18 +1398,15 @@
(set! actual-content null) (set! actual-content null)
(set! actual-user-data null) (set! actual-user-data null)
(send c clear)))) (send c clear))))
(define (gone l n)
(if (zero? n)
(cdr l)
(cons (car l) (gone (cdr l) (sub1 n)))))
(define (delete p) (define (delete p)
(send c delete p) (send c delete p)
(when (<= 0 p (sub1 (length actual-content))) (when (<= 0 p (sub1 (length actual-content)))
(if (zero? p) (set! actual-content (gone actual-content p))
(begin (set! actual-user-data (gone actual-user-data p))))
(set! actual-content (cdr actual-content))
(set! actual-user-data (cdr actual-user-data)))
(begin
(set-cdr! (list-tail actual-content (sub1 p))
(list-tail actual-content (add1 p)))
(set-cdr! (list-tail actual-user-data (sub1 p))
(list-tail actual-user-data (add1 p)))))))
(define db (if list? (define db (if list?
(make-object button% (make-object button%
"Delete" cdp "Delete" cdp
@ -1646,22 +1643,20 @@
(define (canvas-frame flags) (define (canvas-frame flags)
(define f (make-frame frame% "Canvas Test" #f #f 250)) (define f (make-frame frame% "Canvas Test" #f #f 250))
(define p (make-object vertical-panel% f)) (define p (make-object vertical-panel% f))
(define c% (class100 canvas% (-name -swapped-name p) (define c% (class canvas%
(init -name -swapped-name p)
(inherit get-dc get-scroll-pos get-scroll-range get-scroll-page (inherit get-dc get-scroll-pos get-scroll-range get-scroll-page
get-client-size get-virtual-size get-view-start) get-client-size get-virtual-size get-view-start)
(rename [super-init-manual-scrollbars init-manual-scrollbars] (define name -name)
[super-init-auto-scrollbars init-auto-scrollbars]) (define swapped-name -swapped-name)
(private-field (define auto? #f)
[name -name] (define incremental? #f)
[swapped-name -swapped-name] (define vw 10)
[auto? #f] (define vh 10)
[incremental? #f] (public*
[vw 10]
[vh 10])
(public
[inc-mode (lambda (x) (set! incremental? x))] [inc-mode (lambda (x) (set! incremental? x))]
[set-vsize (lambda (w h) (set! vw w) (set! vh h))]) [set-vsize (lambda (w h) (set! vw w) (set! vh h))])
(override (override*
[on-paint [on-paint
(lambda () (lambda ()
(let ([s (format "V: p: ~s r: ~s g: ~s H: ~s ~s ~s" (let ([s (format "V: p: ~s r: ~s g: ~s H: ~s ~s ~s"
@ -1697,12 +1692,11 @@
(unless incremental? (on-paint)))] (unless incremental? (on-paint)))]
[init-auto-scrollbars (lambda x [init-auto-scrollbars (lambda x
(set! auto? #t) (set! auto? #t)
(super-init-auto-scrollbars . x))] (super init-auto-scrollbars . x))]
[init-manual-scrollbars (lambda x [init-manual-scrollbars (lambda x
(set! auto? #f) (set! auto? #f)
(super-init-manual-scrollbars . x))]) (super init-manual-scrollbars . x))])
(sequence (super-init p flags)))
(super-init p flags))))
(define un-name "Unmanaged scroll") (define un-name "Unmanaged scroll")
(define m-name "Automanaged scroll") (define m-name "Automanaged scroll")
(define c1 (make-object c% un-name m-name p)) (define c1 (make-object c% un-name m-name p))
@ -2118,15 +2112,15 @@
(super-init) (super-init)
(start 1000 #t)))))) (start 1000 #t))))))
(define bp (make-object vertical-panel% ap '(border))) (define bp0 (make-object vertical-panel% ap '(border)))
(define bp1 (make-object horizontal-panel% bp)) (define bp1 (make-object horizontal-panel% bp0))
(define bp2 (make-object horizontal-pane% bp)) (define bp2 (make-object horizontal-pane% bp0))
(define mp (make-object vertical-panel% ap '(border))) (define mp (make-object vertical-panel% ap '(border)))
(define mp1 (make-object horizontal-panel% mp)) (define mp1 (make-object horizontal-panel% mp))
(define mp2 (make-object horizontal-pane% mp)) (define mp2 (make-object horizontal-pane% mp))
(define pp (make-object horizontal-pane% ap)) (define pp (make-object horizontal-pane% ap))
(send bp stretchable-height #f) (send bp0 stretchable-height #f)
(make-object button% "Make Menus Frame" pp (lambda (b e) (menu-frame))) (make-object button% "Make Menus Frame" pp (lambda (b e) (menu-frame)))
(make-object horizontal-pane% pp) (make-object horizontal-pane% pp)
(make-object button% "Make Panel Frame" pp (lambda (b e) (panel-frame))) (make-object button% "Make Panel Frame" pp (lambda (b e) (panel-frame)))