commit c0f03edcee902ccee68ad9ae1cd66f26e85e25d7
parent f0fd3e6b6b5e6bfbb8c504bc636bbacabbd6e84b
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 5 Aug 2007 15:49:45 +0000
scribble HTML output: add page-specific table-of-contents; also add call-with-values and values to reference
svn: r7025
original commit: 36c962cae107a3c83e649bb16b471825ab92078f
Diffstat:
5 files changed, 219 insertions(+), 82 deletions(-)
diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss
@@ -273,24 +273,32 @@
;; ----------------------------------------
- (define/public (table-of-contents part ht)
+ (define/private (do-table-of-contents part ht delta quiet)
(make-table #f (render-toc part
- (sub1 (length (collected-info-number
- (part-collected-info part))))
- #t)))
+ (+ delta
+ (length (collected-info-number
+ (part-collected-info part))))
+ #t
+ quiet)))
+
+ (define/public (table-of-contents part ht)
+ (do-table-of-contents part ht -1 not))
(define/public (local-table-of-contents part ht)
(table-of-contents part ht))
- (define/private (render-toc part base-len skip?)
+ (define/public (quiet-table-of-contents part ht)
+ (do-table-of-contents part ht 1 (lambda (x) #t)))
+
+ (define/private (render-toc part base-len skip? quiet)
(let ([number (collected-info-number (part-collected-info part))])
(let ([subs
- (if (not (and (styled-part? part)
- (eq? 'quiet (styled-part-style part))
- (not (= base-len (sub1 (length number))))))
+ (if (quiet (and (styled-part? part)
+ (eq? 'quiet (styled-part-style part))
+ (not (= base-len (sub1 (length number))))))
(apply
append
- (map (lambda (p) (render-toc p base-len #f)) (part-parts part)))
+ (map (lambda (p) (render-toc p base-len #f quiet)) (part-parts part)))
null)])
(if skip?
subs
diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss
@@ -32,7 +32,8 @@
get-dest-directory
format-number
strip-aux
- lookup)
+ lookup
+ quiet-table-of-contents)
(define/override (get-suffix) #".html")
@@ -47,7 +48,11 @@
fns)
ht))
- (define/public (part-whole-page? d)
+ (define/public (part-whole-page? p ht)
+ (let ([dest (lookup p ht `(part ,(part-tag p)))])
+ (caddr dest)))
+
+ (define/public (current-part-whole-page?)
#f)
(define/override (collect-part-tag d ht number)
@@ -55,7 +60,7 @@
`(part ,(part-tag d))
(list (current-output-file)
(part-title-content d)
- (part-whole-page? d))))
+ (current-part-whole-page?))))
(define/override (collect-target-element i ht)
(hash-table-put! ht
@@ -71,37 +76,117 @@
(if p
(loop p d)
(values d mine))))])
- `((div ((class "tocview"))
- (div ((class "tocviewtitle"))
- (a ((href "index.html")
- (class "tocviewlink"))
- ,@(render-content (part-title-content top) d ht)))
- (div nbsp)
- (table
- ((class "tocviewlist")
- (cellspacing "0"))
- ,@(map (lambda (p)
- `(tr
- (td
- ((align "right"))
- ,@(format-number (collected-info-number (part-collected-info p))
- '((tt nbsp))))
- (td
- (a ((href ,(let ([dest (lookup p ht `(part ,(part-tag p)))])
- (format "~a~a~a"
- (from-root (car dest)
- (get-dest-directory))
- (if (caddr dest)
- ""
- "#")
- (if (caddr dest)
- ""
- `(part ,(part-tag p))))))
- (class ,(if (eq? p mine)
- "tocviewselflink"
- "tocviewlink")))
- ,@(render-content (part-title-content p) d ht)))))
- (part-parts top)))))))
+ `((div ((class "tocset"))
+ (div ((class "tocview"))
+ (div ((class "tocviewtitle"))
+ (a ((href "index.html")
+ (class "tocviewlink"))
+ ,@(render-content (part-title-content top) d ht)))
+ (div nbsp)
+ (table
+ ((class "tocviewlist")
+ (cellspacing "0"))
+ ,@(map (lambda (p)
+ `(tr
+ (td
+ ((align "right"))
+ ,@(format-number (collected-info-number (part-collected-info p))
+ '((tt nbsp))))
+ (td
+ (a ((href ,(let ([dest (lookup p ht `(part ,(part-tag p)))])
+ (format "~a~a~a"
+ (from-root (car dest)
+ (get-dest-directory))
+ (if (caddr dest)
+ ""
+ "#")
+ (if (caddr dest)
+ ""
+ `(part ,(part-tag p))))))
+ (class ,(if (eq? p mine)
+ "tocviewselflink"
+ "tocviewlink")))
+ ,@(render-content (part-title-content p) d ht)))))
+ (part-parts top))))
+ ,@(if (ormap (lambda (p) (part-whole-page? p ht)) (part-parts d))
+ null
+ (let ([ps (cdr
+ (let flatten ([d d])
+ (cons d
+ (apply
+ append
+ (letrec ([flow-targets
+ (lambda (flow)
+ (apply append (map flow-element-targets (flow-paragraphs flow))))]
+ [flow-element-targets
+ (lambda (e)
+ (cond
+ [(table? e) (table-targets e)]
+ [(paragraph? e) (para-targets e)]
+ [(itemization? e)
+ (apply append (map flow-targets (itemization-flows e)))]
+ [(blockquote? e)
+ (apply append (map flow-element-targets (blockquote-paragraphs e)))]
+ [(delayed-flow-element? e)
+ null]))]
+ [para-targets
+ (lambda (para)
+ (let loop ([c (paragraph-content para)])
+ (cond
+ [(empty? c) null]
+ [else (let ([a (car c)])
+ (cond
+ [(toc-target-element? a)
+ (cons a (loop (cdr c)))]
+ [(element? a)
+ (append (loop (element-content a))
+ (loop (cdr c)))]
+ [(delayed-element? a)
+ (loop (cons (force-delayed-element a this d ht)
+ (cdr c)))]
+ [else
+ (loop (cdr c))]))])))]
+ [table-targets
+ (lambda (table)
+ (apply append
+ (map (lambda (flows)
+ (apply append (map (lambda (f)
+ (if (eq? f 'cont)
+ null
+ (flow-targets f)))
+ flows)))
+ (table-flowss table))))])
+ (apply append (map flow-element-targets (flow-paragraphs (part-flow d)))))
+ (map flatten (part-parts d))))))])
+ (if (null? ps)
+ null
+ `((div ((class "tocsub"))
+ (div ((class "tocsubtitle"))
+ "On this page:")
+ (table
+ ((class "tocsublist")
+ (cellspacing "0"))
+ ,@(map (lambda (p)
+ (parameterize ([current-no-links #t])
+ `(tr
+ (td
+ ,@(if (part? p)
+ `((span ((class "tocsublinknumber"))
+ ,@(format-number (collected-info-number (part-collected-info p))
+ '((tt nbsp)))))
+ '(""))
+ (a ((href ,(if (part? p)
+ (let ([dest (lookup p ht `(part ,(part-tag p)))])
+ (format "#~a"
+ `(part ,(part-tag p))))
+ (format "#~a" (target-element-tag p))))
+ (class ,(if (part? p)
+ "tocsubseclink"
+ "tocsublink")))
+ ,@(if (part? p)
+ (render-content (part-title-content p) d ht)
+ (render-content (element-content p) d ht)))))))
+ ps)))))))))))
(define/public (render-one-part d ht fn number)
(parameterize ([current-output-file fn])
@@ -356,7 +441,7 @@
(build-path fn "index.html"))
fns)))
- (define/override (part-whole-page? d)
+ (define/override (current-part-whole-page?)
((collecting-sub) . <= . 2))
(define/private (toc-part? d)
diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss
@@ -487,7 +487,7 @@
(loop (cdr a) (cons (car a) o-accum)))))
(loop (cdr a) (cons (car a) r-accum))))]
[(tagged) (if first?
- (make-target-element
+ (make-toc-target-element
#f
(list (to-element (make-just-context (car prototype)
stx-id)))
@@ -661,12 +661,13 @@
(cons #t (map (lambda (x) #f) (cdr prototypes))))))
(content-thunk))))))
- (define (make-target-element* stx-id content wrappers)
+ (define (make-target-element* inner-make-target-element stx-id content wrappers)
(if (null? wrappers)
content
(make-target-element*
+ make-target-element
stx-id
- (make-target-element
+ (inner-make-target-element
#f
(list content)
(register-scheme-definition
@@ -686,38 +687,42 @@
(cons
(list (make-flow
(list
- (let* ([the-name
- (make-target-element*
- stx-id
- (to-element (if (pair? name)
- (map (lambda (x)
- (make-just-context x stx-id))
- name)
- stx-id))
- (let ([name (if (pair? name)
- (car name)
- name)])
- (list* (list name)
- (list name '?)
- (list 'make- name)
- (append
- (map (lambda (f)
- (list name '- (car f)))
- fields)
- (if immutable?
- null
- (map (lambda (f)
- (list 'set- name '- (car f) '!))
- fields))))))]
- [short-width (apply +
- (length fields)
- 8
- (map (lambda (s)
- (string-length (symbol->string s)))
- (append (if (pair? name)
- name
- (list name))
- (map car fields))))])
+ (let* ([the-name
+ (let ([just-name
+ (make-target-element*
+ make-toc-target-element
+ stx-id
+ (to-element (if (pair? name)
+ (make-just-context (car name) stx-id)
+ stx-id))
+ (let ([name (if (pair? name)
+ (car name)
+ name)])
+ (list* (list name)
+ (list name '?)
+ (list 'make- name)
+ (append
+ (map (lambda (f)
+ (list name '- (car f)))
+ fields)
+ (if immutable?
+ null
+ (map (lambda (f)
+ (list 'set- name '- (car f) '!))
+ fields))))))])
+ (if (pair? name)
+ (to-element (list just-name
+ (make-just-context (cadr name) stx-id)))
+ just-name))]
+ [short-width (apply +
+ (length fields)
+ 8
+ (map (lambda (s)
+ (string-length (symbol->string s)))
+ (append (if (pair? name)
+ name
+ (list name))
+ (map car fields))))])
(if (and (short-width . < . max-proto-width)
(not immutable?)
(not transparent?))
@@ -836,7 +841,7 @@
(list (make-flow
(list
(make-paragraph
- (list (make-target-element
+ (list (make-toc-target-element
#f
(list (to-element (make-just-context name stx-id)))
(register-scheme-definition stx-id))
@@ -885,7 +890,7 @@
. ,(cdr form)))))))
(and kw-id
(eq? form (car forms))
- (make-target-element
+ (make-toc-target-element
#f
(list (to-element (make-just-context (if (pair? form)
(car form)
diff --git a/collects/scribble/scribble.css b/collects/scribble/scribble.css
@@ -35,15 +35,24 @@
border: 0.5em solid #F5F5DC;
}
- .tocview {
+ .tocset {
position: relative;
float: left;
width: 10em;
margin-right: 2em;
+ }
+
+ .tocview {
text-align: left;
background-color: #F5F5DC;
}
+ .tocsub {
+ margin-top: 1em;
+ text-align: left;
+ background-color: #DCF5F5;
+ }
+
.tocviewtitle {
font-size: 80%;
font-weight: bold;
@@ -63,6 +72,35 @@
text-decoration: none;
}
+ .tocsublist {
+ margin: 0.2em 0.2em 0.2em 0.2em;
+ }
+
+ .tocsublist td {
+ vertical-align: top;
+ padding-left: 1em;
+ text-indent: -1em;
+ }
+
+ .tocsublinknumber {
+ font-size: 80%;
+ }
+
+ .tocsublink {
+ text-decoration: none;
+ }
+
+ .tocsubseclink {
+ font-size: 80%;
+ text-decoration: none;
+ }
+
+ .tocsubtitle {
+ font-size: 80%;
+ font-style: italic;
+ margin: 0.2em 0.2em 0.2em 0.2em;
+ }
+
.leftindent {
margin-left: 1em;
margin-right: 0em;
diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss
@@ -72,6 +72,7 @@
[element ([style any/c]
[content list?])]
[(target-element element) ([tag tag?])]
+ [(toc-target-element target-element) ()]
[(link-element element) ([tag tag?])]
[(index-element element) ([tag tag?]
[plain-seq (listof string?)]
