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

scribble HTML output: add page-specific table-of-contents; also add call-with-values and values to reference

Browse Source 
svn: r7025

original commit: 36c962cae107a3c83e649bb16b471825ab92078f
This commit is contained in:
Matthew Flatt 2007-08-05 15:49:45 +00:00
parent f0fd3e6b6b
commit c0f03edcee
5 changed files with 219 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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 (make-table #f (render-toc part
(sub1 (length (collected-info-number (+ delta
(part-collected-info part)))) (length (collected-info-number
#t))) (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) (define/public (local-table-of-contents part ht)
(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 ([number (collected-info-number (part-collected-info part))])
(let ([subs (let ([subs
(if (not (and (styled-part? part) (if (quiet (and (styled-part? part)
(eq? 'quiet (styled-part-style part)) (eq? 'quiet (styled-part-style part))
(not (= base-len (sub1 (length number)))))) (not (= base-len (sub1 (length number))))))
(apply (apply
append 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)]) null)])
(if skip? (if skip?
subs subs

155
collects/scribble/html-render.ss
View File

@ -32,7 +32,8 @@
get-dest-directory get-dest-directory
format-number format-number
strip-aux strip-aux
lookup) lookup
quiet-table-of-contents)
(define/override (get-suffix) #".html") (define/override (get-suffix) #".html")
@ -47,7 +48,11 @@
fns) fns)
ht)) 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) #f)
(define/override (collect-part-tag d ht number) (define/override (collect-part-tag d ht number)
@ -55,7 +60,7 @@
`(part ,(part-tag d)) `(part ,(part-tag d))
(list (current-output-file) (list (current-output-file)
(part-title-content d) (part-title-content d)
(part-whole-page? d)))) (current-part-whole-page?))))
(define/override (collect-target-element i ht) (define/override (collect-target-element i ht)
(hash-table-put! ht (hash-table-put! ht
@ -71,37 +76,117 @@
(if p (if p
(loop p d) (loop p d)
(values d mine))))]) (values d mine))))])
`((div ((class "tocview")) `((div ((class "tocset"))
(div ((class "tocviewtitle")) (div ((class "tocview"))
(a ((href "index.html") (div ((class "tocviewtitle"))
(class "tocviewlink")) (a ((href "index.html")
,@(render-content (part-title-content top) d ht))) (class "tocviewlink"))
(div nbsp) ,@(render-content (part-title-content top) d ht)))
(table (div nbsp)
((class "tocviewlist") (table
(cellspacing "0")) ((class "tocviewlist")
,@(map (lambda (p) (cellspacing "0"))
`(tr ,@(map (lambda (p)
(td `(tr
((align "right")) (td
,@(format-number (collected-info-number (part-collected-info p)) ((align "right"))
'((tt nbsp)))) ,@(format-number (collected-info-number (part-collected-info p))
(td '((tt nbsp))))
(a ((href ,(let ([dest (lookup p ht `(part ,(part-tag p)))]) (td
(format "~a~a~a" (a ((href ,(let ([dest (lookup p ht `(part ,(part-tag p)))])
(from-root (car dest) (format "~a~a~a"
(get-dest-directory)) (from-root (car dest)
(if (caddr dest) (get-dest-directory))
"" (if (caddr dest)
"#") ""
(if (caddr dest) "#")
"" (if (caddr dest)
`(part ,(part-tag p)))))) ""
(class ,(if (eq? p mine) `(part ,(part-tag p))))))
"tocviewselflink" (class ,(if (eq? p mine)
"tocviewlink"))) "tocviewselflink"
,@(render-content (part-title-content p) d ht))))) "tocviewlink")))
(part-parts top))))))) ,@(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) (define/public (render-one-part d ht fn number)
(parameterize ([current-output-file fn]) (parameterize ([current-output-file fn])
@ -356,7 +441,7 @@
(build-path fn "index.html")) (build-path fn "index.html"))
fns))) fns)))
(define/override (part-whole-page? d) (define/override (current-part-whole-page?)
((collecting-sub) . <= . 2)) ((collecting-sub) . <= . 2))
(define/private (toc-part? d) (define/private (toc-part? d)

79
collects/scribble/manual.ss
View File

@ -487,7 +487,7 @@
(loop (cdr a) (cons (car a) o-accum))))) (loop (cdr a) (cons (car a) o-accum)))))
(loop (cdr a) (cons (car a) r-accum))))] (loop (cdr a) (cons (car a) r-accum))))]
[(tagged) (if first? [(tagged) (if first?
(make-target-element (make-toc-target-element
#f #f
(list (to-element (make-just-context (car prototype) (list (to-element (make-just-context (car prototype)
stx-id))) stx-id)))
@ -661,12 +661,13 @@
(cons #t (map (lambda (x) #f) (cdr prototypes)))))) (cons #t (map (lambda (x) #f) (cdr prototypes))))))
(content-thunk)))))) (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) (if (null? wrappers)
content content
(make-target-element* (make-target-element*
make-target-element
stx-id stx-id
(make-target-element (inner-make-target-element
#f #f
(list content) (list content)
(register-scheme-definition (register-scheme-definition
@ -686,38 +687,42 @@
(cons (cons
(list (make-flow (list (make-flow
(list (list
(let* ([the-name (let* ([the-name
(make-target-element* (let ([just-name
stx-id (make-target-element*
(to-element (if (pair? name) make-toc-target-element
(map (lambda (x) stx-id
(make-just-context x stx-id)) (to-element (if (pair? name)
name) (make-just-context (car name) stx-id)
stx-id)) stx-id))
(let ([name (if (pair? name) (let ([name (if (pair? name)
(car name) (car name)
name)]) name)])
(list* (list name) (list* (list name)
(list name '?) (list name '?)
(list 'make- name) (list 'make- name)
(append (append
(map (lambda (f) (map (lambda (f)
(list name '- (car f))) (list name '- (car f)))
fields) fields)
(if immutable? (if immutable?
null null
(map (lambda (f) (map (lambda (f)
(list 'set- name '- (car f) '!)) (list 'set- name '- (car f) '!))
fields))))))] fields))))))])
[short-width (apply + (if (pair? name)
(length fields) (to-element (list just-name
8 (make-just-context (cadr name) stx-id)))
(map (lambda (s) just-name))]
(string-length (symbol->string s))) [short-width (apply +
(append (if (pair? name) (length fields)
name 8
(list name)) (map (lambda (s)
(map car fields))))]) (string-length (symbol->string s)))
(append (if (pair? name)
name
(list name))
(map car fields))))])
(if (and (short-width . < . max-proto-width) (if (and (short-width . < . max-proto-width)
(not immutable?) (not immutable?)
(not transparent?)) (not transparent?))
@ -836,7 +841,7 @@
(list (make-flow (list (make-flow
(list (list
(make-paragraph (make-paragraph
(list (make-target-element (list (make-toc-target-element
#f #f
(list (to-element (make-just-context name stx-id))) (list (to-element (make-just-context name stx-id)))
(register-scheme-definition stx-id)) (register-scheme-definition stx-id))
@ -885,7 +890,7 @@
. ,(cdr form))))))) . ,(cdr form)))))))
(and kw-id (and kw-id
(eq? form (car forms)) (eq? form (car forms))
(make-target-element (make-toc-target-element
#f #f
(list (to-element (make-just-context (if (pair? form) (list (to-element (make-just-context (if (pair? form)
(car form) (car form)

40
collects/scribble/scribble.css
View File

@ -35,15 +35,24 @@
border: 0.5em solid #F5F5DC; border: 0.5em solid #F5F5DC;
} }
.tocview { .tocset {
position: relative; position: relative;
float: left; float: left;
width: 10em; width: 10em;
margin-right: 2em; margin-right: 2em;
}
.tocview {
text-align: left; text-align: left;
background-color: #F5F5DC; background-color: #F5F5DC;
} }
.tocsub {
margin-top: 1em;
text-align: left;
background-color: #DCF5F5;
}
.tocviewtitle { .tocviewtitle {
font-size: 80%; font-size: 80%;
font-weight: bold; font-weight: bold;
@ -63,6 +72,35 @@
text-decoration: none; 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 { .leftindent {
margin-left: 1em; margin-left: 1em;
margin-right: 0em; margin-right: 0em;

1
collects/scribble/struct.ss
View File

@ -72,6 +72,7 @@
[element ([style any/c] [element ([style any/c]
[content list?])] [content list?])]
[(target-element element) ([tag tag?])] [(target-element element) ([tag tag?])]
[(toc-target-element target-element) ()]
[(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?)]