commit f7803f005e78743bd3d9606e55822909938c7781
parent c0f03edcee902ccee68ad9ae1cd66f26e85e25d7
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 7 Aug 2007 20:39:54 +0000
improve scribble index support
svn: r7047
original commit: ab9c34a8ecdff19c469d167a16f44f1863f546f3
Diffstat:
9 files changed, 304 insertions(+), 145 deletions(-)
diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss
@@ -69,8 +69,8 @@
(let ([p-ht (make-hash-table 'equal)])
(when (part-title-content d)
(collect-content (part-title-content d) p-ht))
- (when (part-tag d)
- (collect-part-tag d p-ht number))
+ (collect-part-tags d p-ht number)
+ (collect-content (part-to-collect d) p-ht)
(collect-flow (part-flow d) p-ht)
(let loop ([parts (part-parts d)]
[pos 1])
@@ -91,8 +91,10 @@
(lambda (k v)
(hash-table-put! ht k v)))))
- (define/public (collect-part-tag d ht number)
- (hash-table-put! ht `(part ,(part-tag d)) (list (part-title-content d) number)))
+ (define/public (collect-part-tags d ht number)
+ (for-each (lambda (t)
+ (hash-table-put! ht `(part ,t) (list (part-title-content d) number)))
+ (part-tags d)))
(define/public (collect-content c ht)
(for-each (lambda (i)
@@ -316,7 +318,7 @@
(list
(make-element 'hspace '(" "))))
(part-title-content part))
- `(part ,(part-tag part))))))))
+ `(part ,(car (part-tags part)))))))))
subs)])
(if (and (= 1 (length number))
(or (not (car number))
diff --git a/collects/scribble/basic.ss b/collects/scribble/basic.ss
@@ -119,10 +119,13 @@
;; ----------------------------------------
- (provide index index* as-index index-section)
+ (provide section-index index index* as-index index-section)
+
+ (define (section-index . elems)
+ (make-section-index-decl (map element->string elems) elems))
(define (gen-target)
- (format "index:~s:~s" (current-seconds) (gensym)))
+ (format "index:~s:~s" (current-inexact-milliseconds) (gensym)))
(define (record-index word-seq element-seq tag content)
(make-index-element
@@ -155,9 +158,10 @@
(define (index-section tag)
(make-unnumbered-part
- tag
+ (and tag (list tag))
(list "Index")
#f
+ null
(make-flow (list (make-delayed-flow-element
(lambda (renderer sec ht)
(let ([l null])
@@ -180,7 +184,14 @@
[(string-ci=? (car a) (car b))
(loop (cdr a) (cdr b))]
[else
- (string-ci<? (car a) (car b))]))))])
+ (string-ci<? (car a) (car b))]))))]
+ [commas (lambda (l)
+ (if (or (null? l)
+ (null? (cdr l)))
+ l
+ (cdr (apply append (map (lambda (i)
+ (list ", " i))
+ l)))))])
(make-table
'index
(map (lambda (i)
@@ -189,11 +200,12 @@
(make-paragraph
(list
(make-link-element
- #f
- (caddr i)
+ "indexlink"
+ (commas (caddr i))
(car i))))))))
l))))))))
- null))
+ null
+ 'index))
;; ----------------------------------------
diff --git a/collects/scribble/decode.ss b/collects/scribble/decode.ss
@@ -19,7 +19,9 @@
[part-start ([depth integer?]
[tag (or/c false/c string?)]
[title list?])]
- [splice ([run list?])])
+ [splice ([run list?])]
+ [section-index-decl ([plain-seq (listof string?)]
+ [entry-seq list?])])
(define (decode-string s)
(let loop ([l '((#rx"---" mdash)
@@ -49,15 +51,39 @@
null
(list (decode-paragraph (reverse (skip-whitespace accum))))))
- (define (decode-flow* l tag style title part-depth)
- (let loop ([l l][next? #f][accum null][title title][tag tag][style style])
+ (define (decode-flow* l keys tag style title part-depth)
+ (let loop ([l l][next? #f][keys keys][accum null][title title][tag tag][style style])
(cond
- [(null? l) (make-styled-part tag
- title
- #f
- (make-flow (decode-accum-para accum))
- null
- style)]
+ [(null? l)
+ (let ([tags (map (lambda (k)
+ (format "secindex:~a:~a" (current-inexact-milliseconds) (gensym)))
+ keys)]
+ [tag (or tag (format "sec:~a:~a" (current-inexact-milliseconds) (gensym)))])
+ (make-styled-part (cons tag
+ tags)
+ title
+ #f
+ (let ([l (map (lambda (k tag)
+ (make-index-element
+ #f
+ null
+ `(part ,tag)
+ (section-index-decl-plain-seq k)
+ (section-index-decl-entry-seq k)))
+ keys tags)])
+ (if title
+ (cons (make-index-element
+ #f
+ null
+ `(part ,tag)
+ (list (regexp-replace #px"^(?:A|An|The)\\s" (content->string title)
+ ""))
+ (list (make-element #f title)))
+ l)
+ l))
+ (make-flow (decode-accum-para accum))
+ null
+ style))]
[(title-decl? (car l))
(unless part-depth
(error 'decode
@@ -67,16 +93,17 @@
(error 'decode
"found extra title: ~v"
(car l)))
- (loop (cdr l) next? accum
+ (loop (cdr l) next? keys accum
(title-decl-content (car l))
(title-decl-tag (car l))
(title-decl-style (car l)))]
[(flow-element? (car l))
(let ([para (decode-accum-para accum)]
- [part (decode-flow* (cdr l) tag style title part-depth)])
- (make-styled-part (part-tag part)
+ [part (decode-flow* (cdr l) keys tag style title part-depth)])
+ (make-styled-part (part-tags part)
(part-title-content part)
(part-collected-info part)
+ (part-to-collect part)
(make-flow (append para
(list (car l))
(flow-paragraphs (part-flow part))))
@@ -84,10 +111,11 @@
(styled-part-style part)))]
[(part? (car l))
(let ([para (decode-accum-para accum)]
- [part (decode-flow* (cdr l) tag style title part-depth)])
- (make-styled-part (part-tag part)
+ [part (decode-flow* (cdr l) keys tag style title part-depth)])
+ (make-styled-part (part-tags part)
(part-title-content part)
(part-collected-info part)
+ (part-to-collect part)
(make-flow (append para
(flow-paragraphs
(part-flow part))))
@@ -112,41 +140,45 @@
(part-start-tag s)
(part-start-title s)
(add1 part-depth))]
- [part (decode-flow* l tag style title part-depth)])
- (make-styled-part (part-tag part)
+ [part (decode-flow* l keys tag style title part-depth)])
+ (make-styled-part (part-tags part)
(part-title-content part)
(part-collected-info part)
+ (part-to-collect part)
(make-flow para)
(cons s (part-parts part))
(styled-part-style part)))
(loop (cdr l) (cons (car l) s-accum)))))]
[(splice? (car l))
- (loop (append (splice-run (car l)) (cdr l)) next? accum title tag style)]
- [(null? (cdr l)) (loop null #f (cons (car l) accum) title tag style)]
+ (loop (append (splice-run (car l)) (cdr l)) next? keys accum title tag style)]
+ [(null? (cdr l)) (loop null #f keys (cons (car l) accum) title tag style)]
+ [(section-index-decl? (car l))
+ (loop (cdr l) next? (cons (car l) keys) accum title tag style)]
[(and (pair? (cdr l))
(splice? (cadr l)))
- (loop (cons (car l) (append (splice-run (cadr l)) (cddr l))) next? accum title tag style)]
+ (loop (cons (car l) (append (splice-run (cadr l)) (cddr l))) next? keys accum title tag style)]
[(line-break? (car l))
(if next?
- (loop (cdr l) #t accum title tag style)
+ (loop (cdr l) #t keys accum title tag style)
(let ([m (match-newline-whitespace (cdr l))])
(if m
- (let ([part (loop m #t null title tag style)])
- (make-styled-part (part-tag part)
+ (let ([part (loop m #t keys null title tag style)])
+ (make-styled-part (part-tags part)
(part-title-content part)
(part-collected-info part)
+ (part-to-collect part)
(make-flow (append (decode-accum-para accum)
(flow-paragraphs (part-flow part))))
(part-parts part)
(styled-part-style part)))
- (loop (cdr l) #f (cons (car l) accum) title tag style))))]
- [else (loop (cdr l) #f (cons (car l) accum) title tag style)])))
+ (loop (cdr l) #f keys (cons (car l) accum) title tag style))))]
+ [else (loop (cdr l) #f keys (cons (car l) accum) title tag style)])))
(define (decode-part l tag title depth)
- (decode-flow* l tag #f title depth))
+ (decode-flow* l null tag #f title depth))
(define (decode-flow l)
- (part-flow (decode-flow* l #f #f #f #f)))
+ (part-flow (decode-flow* l null #f #f #f #f)))
(define (match-newline-whitespace l)
(cond
diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss
@@ -19,6 +19,7 @@
(define next-separate-page (make-parameter #f))
(define collecting-sub (make-parameter 0))
(define current-no-links (make-parameter #f))
+ (define extra-breaking? (make-parameter #f))
;; ----------------------------------------
;; main mixin
@@ -49,18 +50,20 @@
ht))
(define/public (part-whole-page? p ht)
- (let ([dest (lookup p ht `(part ,(part-tag p)))])
+ (let ([dest (lookup p ht `(part ,(car (part-tags p))))])
(caddr dest)))
(define/public (current-part-whole-page?)
#f)
- (define/override (collect-part-tag d ht number)
- (hash-table-put! ht
- `(part ,(part-tag d))
- (list (current-output-file)
- (part-title-content d)
- (current-part-whole-page?))))
+ (define/override (collect-part-tags d ht number)
+ (for-each (lambda (t)
+ (hash-table-put! ht
+ `(part ,t)
+ (list (current-output-file)
+ (part-title-content d)
+ (current-part-whole-page?))))
+ (part-tags d)))
(define/override (collect-target-element i ht)
(hash-table-put! ht
@@ -93,7 +96,7 @@
,@(format-number (collected-info-number (part-collected-info p))
'((tt nbsp))))
(td
- (a ((href ,(let ([dest (lookup p ht `(part ,(part-tag p)))])
+ (a ((href ,(let ([dest (lookup p ht `(part ,(car (part-tags p))))])
(format "~a~a~a"
(from-root (car dest)
(get-dest-directory))
@@ -102,7 +105,7 @@
"#")
(if (caddr dest)
""
- `(part ,(part-tag p))))))
+ `(part ,(car (part-tags p)))))))
(class ,(if (eq? p mine)
"tocviewselflink"
"tocviewlink")))
@@ -167,7 +170,8 @@
((class "tocsublist")
(cellspacing "0"))
,@(map (lambda (p)
- (parameterize ([current-no-links #t])
+ (parameterize ([current-no-links #t]
+ [extra-breaking? #t])
`(tr
(td
,@(if (part? p)
@@ -176,9 +180,9 @@
'((tt nbsp)))))
'(""))
(a ((href ,(if (part? p)
- (let ([dest (lookup p ht `(part ,(part-tag p)))])
+ (let ([dest (lookup p ht `(part ,(car (part-tags p))))])
(format "#~a"
- `(part ,(part-tag p))))
+ `(part ,(car (part-tags p)))))
(format "#~a" (target-element-tag p))))
(class ,(if (part? p)
"tocsubseclink"
@@ -221,9 +225,9 @@
[(2) 'h4]
[else 'h5])
,@(format-number number '((tt nbsp)))
- ,@(if (part-tag d)
- `((a ((name ,(format "~a" `(part ,(part-tag d)))))))
- null)
+ ,@(map (lambda (t)
+ `(a ((name ,(format "~a" `(part ,t))))))
+ (part-tags d))
,@(if (part-title-content d)
(render-content (part-title-content d) d ht)
null))))
@@ -399,7 +403,13 @@
(define/override (render-other i part ht)
(cond
- [(string? i) (list i)]
+ [(string? i) (let ([m (and (extra-breaking?)
+ (regexp-match-positions #rx":" i))])
+ (if m
+ (list* (substring i 0 (cdar m))
+ `(span ((class "mywbr")) " ")
+ (render-other (substring i (cdar m)) part ht))
+ (list i)))]
[(eq? i 'mdash) `(" " ndash " ")]
[(eq? i 'hline) `((hr))]
[(symbol? i) (list i)]
@@ -428,9 +438,7 @@
(define/private (derive-filename d ht)
(let ([fn (format "~a.html" (regexp-replace*
"[^-a-zA-Z0-9_=]"
- (or (format "~a" (part-tag d))
- (content->string (part-title-content d)
- this d ht))
+ (format "~a" (car (part-tags d)))
"_"))])
(when ((string-length fn) . >= . 48)
(error "file name too long (need a tag):" fn))
@@ -560,7 +568,7 @@
(make-link-element
#f
index-content
- `(part ,(part-tag index)))))))))
+ `(part ,(car (part-tags index))))))))))
null))))
d ht)
,@(render-table (make-table
diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss
@@ -6,6 +6,7 @@
(define current-table-mode (make-parameter #f))
(define rendering-tt (make-parameter #f))
+ (define show-link-page-numbers (make-parameter #f))
(define-struct (toc-paragraph paragraph) ())
@@ -69,8 +70,9 @@
(printf "\\newcommand{\\schemeinput}[1]{\\colorbox{LightGray}{\\hspace{-0.5ex}\\schemeinputbg{#1}\\hspace{-0.5ex}}}\n")
(printf "\\newcommand{\\highlighted}[1]{\\colorbox{PaleBlue}{\\hspace{-0.5ex}\\schemeinputbg{#1}\\hspace{-0.5ex}}}\n")
(printf "\\newcommand{\\techlink}[1]{#1}\n")
+ (printf "\\newcommand{\\indexlink}[1]{#1}\n")
(printf "\\newcommand{\\imageleft}[1]{} % drop it\n")
- (printf "\\begin{document}\n")
+ (printf "\\begin{document}\n\\sloppy\n")
(when (part-title-content d)
(printf "\\title{")
(render-content (part-title-content d) d ht)
@@ -82,6 +84,9 @@
(let ([number (collected-info-number (part-collected-info d))])
(when (and (part-title-content d)
(pair? number))
+ (when (and (styled-part? d)
+ (eq? 'index (styled-part-style d)))
+ (printf "\\twocolumn\n\\parskip=0pt\n\\addcontentsline{toc}{section}{Index}\n"))
(printf "\\~a~a{"
(case (length number)
[(0 1) "newpage\n\n\\section"]
@@ -93,10 +98,13 @@
"*"
""))
(render-content (part-title-content d) d ht)
- (printf "}"))
- #;
- (when (part-tag d)
- (printf "\\label{section:~a}" (protect-tag (part-tag d))))
+ (printf "}")
+ (when (and (styled-part? d)
+ (eq? 'index (styled-part-style d)))
+ (printf "\n\n")))
+ (for-each (lambda (t)
+ (printf "\\label{t:~a}" (t-encode `(part ,t))))
+ (part-tags d))
(render-flow (part-flow d) d ht)
(for-each (lambda (sec) (render-part sec ht))
(part-parts d))
@@ -121,48 +129,68 @@
(pair? (link-element-tag e))
(eq? 'part (car (link-element-tag e)))
(null? (element-content e)))])
+ (parameterize ([show-link-page-numbers #f])
+ (when (target-element? e)
+ (printf "\\label{t:~a}" (t-encode (target-element-tag e))))
+ (when part-label?
+ (printf "\\S")
+ (render-content (let ([dest (lookup part ht (link-element-tag e))])
+ (if dest
+ (format-number (cadr dest) null)
+ (list "???")))
+ part
+ ht)
+ (printf " ``"))
+ (let ([style (and (element? e)
+ (element-style e))]
+ [wrap (lambda (e s tt?)
+ (printf "{\\~a{" s)
+ (parameterize ([rendering-tt (or tt?
+ (rendering-tt))])
+ (super render-element e part ht))
+ (printf "}}"))])
+ (cond
+ [(symbol? style)
+ (case style
+ [(italic) (wrap e "textit" #f)]
+ [(bold) (wrap e "textbf" #f)]
+ [(tt) (wrap e "mytexttt" #t)]
+ [(sf) (wrap e "textsf" #f)]
+ [(subscript) (wrap e "textsub" #f)]
+ [(superscript) (wrap e "textsuper" #f)]
+ [(hspace) (let ([s (content->string (element-content e))])
+ (case (string-length s)
+ [(0) (void)]
+ [else
+ (printf "{\\mytexttt{~a}}"
+ (regexp-replace* #rx"." s "~"))]))]
+ [else (error 'latex-render "unrecognzied style symbol: ~s" style)])]
+ [(string? style)
+ (wrap e style (regexp-match? #px"^scheme(?!error)" style))]
+ [(image-file? style)
+ (let ([fn (install-file (image-file-path style))])
+ (printf "\\includegraphics{~a}" fn))]
+ [else (super render-element e part ht)])))
(when part-label?
- (printf "\\S")
- (render-content (let ([dest (lookup part ht (link-element-tag e))])
- (if dest
- (format-number (cadr dest) null)
- (list "???")))
- part
- ht)
- (printf " ``"))
- (let ([style (and (element? e)
- (element-style e))]
- [wrap (lambda (e s tt?)
- (printf "{\\~a{" s)
- (parameterize ([rendering-tt (or tt?
- (rendering-tt))])
- (super render-element e part ht))
- (printf "}}"))])
- (cond
- [(symbol? style)
- (case style
- [(italic) (wrap e "textit" #f)]
- [(bold) (wrap e "textbf" #f)]
- [(tt) (wrap e "mytexttt" #t)]
- [(sf) (wrap e "textsf" #f)]
- [(subscript) (wrap e "textsub" #f)]
- [(superscript) (wrap e "textsuper" #f)]
- [(hspace) (let ([s (content->string (element-content e))])
- (case (string-length s)
- [(0) (void)]
- [else
- (printf "{\\mytexttt{~a}}"
- (regexp-replace* #rx"." s "~"))]))]
- [else (error 'latex-render "unrecognzied style symbol: ~s" style)])]
- [(string? style)
- (wrap e style (regexp-match? #px"^scheme(?!error)" style))]
- [(image-file? style)
- (let ([fn (install-file (image-file-path style))])
- (printf "\\includegraphics{~a}" fn))]
- [else (super render-element e part ht)]))
- (when part-label?
- (printf "''")))
- null)
+ (printf "''"))
+ (when (and (link-element? e)
+ (show-link-page-numbers))
+ (printf ", \\pageref{t:~a}" (t-encode (link-element-tag e))))
+ null))
+
+ (define/private (t-encode s)
+ (apply
+ string-append
+ (map (lambda (c)
+ (cond
+ [(and (or (char-alphabetic? c)
+ (char-numeric? c))
+ ((char->integer c) . < . 128))
+ (string c)]
+ [(char=? c #\space) "_"]
+ [else
+ (format "x~x" (char->integer c))]))
+ (string->list (format "~s" s)))))
(define/override (render-table t part ht)
(let* ([boxed? (eq? 'boxed (table-style t))]
@@ -176,7 +204,7 @@
(equal? "longtable" (car m))
(= 1 (length (car (table-flowss (cadr m))))))))]
[tableform (cond
- [index? "theindex"]
+ [index? "list"]
[(not (current-table-mode))
"longtable"]
[else "tabular"])]
@@ -188,10 +216,11 @@
(null? (car (table-flowss t))))
(parameterize ([current-table-mode (if inline?
(current-table-mode)
- (list tableform t))])
+ (list tableform t))]
+ [show-link-page-numbers (or index?
+ (show-link-page-numbers))])
(cond
- [index?
- (printf "\n\n\\begin{theindex}\n")]
+ [index? (printf "\\begin{list}{}{\\parsep=0pt \\itemsep=1pt \\leftmargin=2ex \\itemindent=-2ex}\n")]
[inline? (void)]
[else
(printf "\n\n~a\\begin{~a}~a{@{}~a}\n"
@@ -223,6 +252,8 @@
[row-style (car row-styles)])
(let loop ([flows flows])
(unless (null? flows)
+ (when index?
+ (printf "\\item "))
(unless (eq? 'cont (car flows))
(let ([cnt (let loop ([flows (cdr flows)][n 1])
(cond
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
@@ -88,11 +88,23 @@
(make-element 'tt (list (substring s spaces))))))))))
strs))))
+ (define-syntax indexed-scheme
+ (syntax-rules ()
+ [(_ x) (add-scheme-index 'x (scheme x))]))
+
+ (define (add-scheme-index s e)
+ (let ([k (if (and (pair? s)
+ (eq? (car s) 'quote))
+ (cadr s)
+ s)])
+ (index* (list (format "~s" k)) (list e) e)))
+
(provide schemeblock SCHEMEBLOCK
schemeblock0 SCHEMEBLOCK0
schemeinput
schememod
scheme schemeresult schemeid schememodname
+ indexed-scheme
litchar
verbatim)
@@ -100,6 +112,7 @@
schemefont schemevalfont schemeresultfont schemeidfont
schemeparenfont schemekeywordfont schememetafont schememodfont
file exec envvar Flag DFlag
+ indexed-file indexed-envvar
link procedure
idefterm)
@@ -130,6 +143,10 @@
(make-element "schemekeyword" (decode-content str)))
(define (file . str)
(make-element 'tt (append (list "\"") (decode-content str) (list "\""))))
+ (define (indexed-file . str)
+ (let* ([f (apply file str)]
+ [s (element->string f)])
+ (index* (list (substring s 1 (sub1 (string-length s)))) (list f) f)))
(define (exec . str)
(make-element 'tt (decode-content str)))
(define (Flag . str)
@@ -138,6 +155,10 @@
(make-element 'tt (cons "--" (decode-content str))))
(define (envvar . str)
(make-element 'tt (decode-content str)))
+ (define (indexed-envvar . str)
+ (let* ([f (apply envvar str)]
+ [s (element->string f)])
+ (index* (list s) (list f) f)))
(define (procedure . str)
(make-element "schemeresult" (append (list "#<procedure:") (decode-content str) (list ">"))))
@@ -183,7 +204,13 @@
(format "tech-term:~a" s))))
(define (deftech . s)
- (*tech make-target-element #f (list (apply defterm s))))
+ (let* ([e (apply defterm s)]
+ [t (*tech make-target-element #f (list e))])
+ (make-index-element #f
+ (list t)
+ (target-element-tag t)
+ (list (element->string e))
+ (list e))))
(define (tech . s)
(*tech make-link-element "techlink" s))
@@ -487,11 +514,17 @@
(loop (cdr a) (cons (car a) o-accum)))))
(loop (cdr a) (cons (car a) r-accum))))]
[(tagged) (if first?
- (make-toc-target-element
- #f
- (list (to-element (make-just-context (car prototype)
- stx-id)))
- (register-scheme-definition stx-id))
+ (let ([tag (register-scheme-definition stx-id)]
+ [content (list (to-element (make-just-context (car prototype)
+ stx-id)))])
+ (make-toc-target-element
+ #f
+ (list (make-index-element #f
+ content
+ tag
+ (list (symbol->string (car prototype)))
+ content))
+ tag))
(to-element (make-just-context (car prototype)
stx-id)))]
[(flat-size) (prototype-size prototype + +)]
@@ -667,14 +700,23 @@
(make-target-element*
make-target-element
stx-id
- (inner-make-target-element
- #f
- (list content)
- (register-scheme-definition
- (datum->syntax-object stx-id
- (string->symbol
- (apply string-append
- (map symbol->string (car wrappers)))))))
+ (let* ([name
+ (apply string-append
+ (map symbol->string (car wrappers)))]
+ [tag
+ (register-scheme-definition
+ (datum->syntax-object stx-id
+ (string->symbol
+ name)))])
+ (inner-make-target-element
+ #f
+ (list
+ (make-index-element #f
+ (list content)
+ tag
+ (list name)
+ (list (schemeidfont (make-element "schemevaluelink" (list name))))))
+ tag))
(cdr wrappers))))
(define (*defstruct stx-id name fields field-contracts immutable? transparent? content-thunk)
@@ -841,10 +883,16 @@
(list (make-flow
(list
(make-paragraph
- (list (make-toc-target-element
- #f
- (list (to-element (make-just-context name stx-id)))
- (register-scheme-definition stx-id))
+ (list (let ([tag (register-scheme-definition stx-id)]
+ [content (list (to-element (make-just-context name stx-id)))])
+ (make-toc-target-element
+ #f
+ (list (make-index-element #f
+ content
+ tag
+ (list (symbol->string name))
+ content))
+ tag))
spacer ":" spacer
(to-element result-contract))))))))
(content-thunk))))
@@ -890,13 +938,21 @@
. ,(cdr form)))))))
(and kw-id
(eq? form (car forms))
- (make-toc-target-element
- #f
- (list (to-element (make-just-context (if (pair? form)
- (car form)
- form)
- kw-id)))
- (register-scheme-form-definition kw-id))))))))
+ (let ([tag (register-scheme-form-definition kw-id)]
+ [content (list (to-element (make-just-context (if (pair? form)
+ (car form)
+ form)
+ kw-id)))])
+ (make-toc-target-element
+ #f
+ (if kw-id
+ (list (make-index-element #f
+ content
+ tag
+ (list (symbol->string (syntax-e kw-id)))
+ content))
+ content)
+ tag))))))))
forms form-procs)
(if (null? sub-procs)
null
diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss
@@ -388,6 +388,7 @@
[vd
(make-link-element "schemevaluelink" (list s) vtag)]
[else s]))))
+ (lambda () s)
(lambda () s))
(literalize-spaces s))
(cond
diff --git a/collects/scribble/scribble.css b/collects/scribble/scribble.css
@@ -118,6 +118,10 @@
font-weight: bold;
}
+ .indexlink {
+ text-decoration: none;
+ }
+
.title {
font-size: 200%;
font-weight: normal;
@@ -405,3 +409,8 @@
.colophon a {
color: gray;
}
+
+ .mywbr {
+ width: 0;
+ font-size: 1px;
+ }
diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss
@@ -52,13 +52,14 @@
(delayed-flow-element? p)))
(provide-structs
- [part ([tag (or/c false/c tag?)]
+ [part ([tags (listof tag?)]
[title-content (or/c false/c list?)]
[collected-info (or/c false/c collected-info?)]
+ [to-collect list?]
[flow flow?]
[parts (listof part?)])]
[(styled-part part) ([style any/c])]
- [(unnumbered-part part) ()]
+ [(unnumbered-part styled-part) ()]
[flow ([paragraphs (listof flow-element?)])]
[paragraph ([content list?])]
[(styled-paragraph paragraph) ([style any/c])]
@@ -96,48 +97,54 @@
delayed-element-ref
delayed-element-set!)
(make-struct-type 'delayed-element #f
- 2 1 #f
+ 3 1 #f
(list (cons prop:serializable
(make-serialize-info
(lambda (d)
- (unless (delayed-element-ref d 2)
+ (unless (delayed-element-ref d 3)
(error 'serialize-delayed-element
"cannot serialize a delayed element that was not resolved: ~e"
d))
- (vector (delayed-element-ref d 2)))
+ (vector (delayed-element-ref d 3)))
#'deserialize-delayed-element
#f
(or (current-load-relative-directory) (current-directory)))))))
(define-syntax delayed-element (list-immutable #'struct:delayed-element
#'make-delayed-element
#'delayed-element?
- (list-immutable #'delayed-element-sizer
+ (list-immutable #'delayed-element-plain
+ #'delayed-element-sizer
#'delayed-element-render)
- (list-immutable #'set-delayed-element-sizer!
+ (list-immutable #'set-delayed-element-plain!
+ #'set-delayed-element-sizer!
#'set-delayed-element-render!)
#t))
(define delayed-element-render (make-struct-field-accessor delayed-element-ref 0))
(define delayed-element-sizer (make-struct-field-accessor delayed-element-ref 1))
+ (define delayed-element-plain (make-struct-field-accessor delayed-element-ref 2))
(define set-delayed-element-render! (make-struct-field-mutator delayed-element-set! 0))
(define set-delayed-element-sizer! (make-struct-field-mutator delayed-element-set! 1))
+ (define set-delayed-element-plain! (make-struct-field-mutator delayed-element-set! 2))
(provide/contract
(struct delayed-element ([render (any/c part? any/c . -> . list?)]
- [sizer (-> any)])))
-
+ [sizer (-> any)]
+ [plain (-> any)])))
+
(provide deserialize-delayed-element)
(define deserialize-delayed-element
(make-deserialize-info values values))
(provide force-delayed-element)
(define (force-delayed-element d renderer sec ht)
- (or (delayed-element-ref d 2)
+ (or (delayed-element-ref d 3)
(let ([v ((delayed-element-ref d 0) renderer sec ht)])
- (delayed-element-set! d 2 v)
+ (delayed-element-set! d 3 v)
v)))
;; ----------------------------------------
- (provide content->string)
+ (provide content->string
+ element->string)
(define content->string
(case-lambda
@@ -154,6 +161,7 @@
[(c)
(cond
[(element? c) (content->string (element-content c))]
+ [(delayed-element? c) (element->string ((delayed-element-plain c)))]
[(string? c) c]
[else (case c
[(ndash) "--"]
