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

misc improvements

Browse Source 
svn: r9812
This commit is contained in:
Eli Barzilay 2008-05-12 08:12:54 +00:00
parent 9d634308ee
commit c0d028e4bc
1 changed files with 994 additions and 1019 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,13 +1,14 @@
#lang scheme/base
(module html-render scheme/base
(require "struct.ss" (require "struct.ss"
scheme/class scheme/class
scheme/path scheme/path
scheme/file scheme/file
scheme/list
scheme/string
mzlib/runtime-path mzlib/runtime-path
setup/main-doc setup/main-doc
setup/main-collects setup/main-collects
mzlib/list
net/url net/url
net/base64 net/base64
scheme/serialize scheme/serialize
@ -20,6 +21,22 @@
(xml:empty-tag-shorthand xml:html-empty-tags) (xml:empty-tag-shorthand xml:html-empty-tags)
(define-runtime-path scribble-css "scribble.css") (define-runtime-path scribble-css "scribble.css")
(define scribble-css-contents
(let* ([read-file
(lambda (file)
(with-input-from-file file
(lambda ()
;; note: file-size can be bigger than the string, but
;; that's fine.
(read-string (file-size file)))))]
[file-getter
(lambda (default-file)
(let ([c #f])
(lambda (file)
(if (or (not file) (equal? file default-file))
(begin (unless c (set! c (read-file default-file))) c)
(read-file file)))))])
(file-getter scribble-css)))
(define current-subdirectory (make-parameter #f)) (define current-subdirectory (make-parameter #f))
(define current-output-file (make-parameter #f)) (define current-output-file (make-parameter #f))
@ -34,10 +51,9 @@
(define (toc-part? d) (define (toc-part? d)
(part-style? d 'toc)) (part-style? d 'toc))
;; HTML anchors are case-insenstive. To make them ;; HTML anchors are case-insenstive. To make them distinct, add a "."
;; distinct, add a "." in front of capital letters. ;; in front of capital letters. Also clean up characters that give
;; Also clean up characters that give browers trouble ;; browers trouble (i.e., the ones that are not allowed as-in in URI
;; (i.e., the ones that are not allowed as-in in URI
;; codecs) by using "~" followed by a hex encoding. ;; codecs) by using "~" followed by a hex encoding.
(define (anchor-name v) (define (anchor-name v)
(if (literal-anchor? v) (if (literal-anchor? v)
@ -66,7 +82,7 @@
(let ([loc (xml:make-location 0 0 0)]) (let ([loc (xml:make-location 0 0 0)])
(lambda strings (xml:make-cdata loc loc (apply string-append strings))))) (lambda strings (xml:make-cdata loc loc (apply string-append strings)))))
(define (script . body) (define (script . body)
`(script ((type "text/javascript")) `(script ([type "text/javascript"])
,(apply literal ,(apply literal
`("\n" `("\n"
,@(map (lambda (x) (if (string? x) x (format "~a" x))) body) ,@(map (lambda (x) (if (string? x) x (format "~a" x))) body)
@ -148,27 +164,27 @@
}}) }})
(define search-field (define search-field
@`p{Search: @(input ((type "text") (id "search_box") @`p{Search: @(input ([type "text"] [id "search_box"]
(onchange "delayed_search(this.value,event);") [onchange "delayed_search(this.value,event);"]
(onkeyup "delayed_search(this.value,event);")))}) [onkeyup "delayed_search(this.value,event);"]))})
(define (search-index-box index-url) ; appears on every page (define (search-index-box index-url) ; appears on every page
(let ([sa string-append]) (let ([sa string-append])
`(input `(input
((style ,(sa "font-size: 75%; margin: 0px; padding: 0px; border: 1px;" ([style ,(sa "font-size: 75%; margin: 0px; padding: 0px; border: 1px;"
" background-color: #eee; color: #888;")) " background-color: #eee; color: #888;")]
(type "text") [type "text"]
(value "...search...") [value "...search..."]
(onkeypress ,(sa "if (event && event.keyCode==13" [onkeypress ,(sa "if (event && event.keyCode==13"
" && this.value.indexOf(\"...search...\")<0) {" " && this.value.indexOf(\"...search...\")<0) {"
" location=\"doc-index.html?q=\"+escape(this.value);" " location=\"doc-index.html?q=\"+escape(this.value);"
" };")) " };")]
(onfocus ,(sa "this.style.color=\"black\";" [onfocus ,(sa "this.style.color=\"black\";"
" if (this.value.indexOf(\"...search...\")>=0)" " if (this.value.indexOf(\"...search...\")>=0)"
" this.value=\"\";")) " this.value=\"\";")]
(onblur ,(sa "if (this.value.match(/^ *$/)) {" [onblur ,(sa "if (this.value.match(/^ *$/)) {"
" this.style.color=\"#888\";" " this.style.color=\"#888\";"
" this.value=\"...search...\"; }")))))) " this.value=\"...search...\"; }")]))))
) )
@ -246,19 +262,19 @@
(define/override (collect-target-element i ci) (define/override (collect-target-element i ci)
(let ([key (generate-tag (target-element-tag i) ci)]) (let ([key (generate-tag (target-element-tag i) ci)])
(collect-put! ci (collect-put! ci key
key (vector (path->relative
(vector (path->relative (let ([p (current-output-file)]) (let ([p (current-output-file)])
(if (redirect-target-element? i) (if (redirect-target-element? i)
(let-values ([(base name dir?) (split-path p)]) (let-values ([(base name dir?) (split-path p)])
(build-path (build-path base
base
(redirect-target-element-alt-path i))) (redirect-target-element-alt-path i)))
p))) p)))
#f #f
(page-target-element? i) (page-target-element? i)
(if (redirect-target-element? i) (if (redirect-target-element? i)
(make-literal-anchor (redirect-target-element-alt-anchor i)) (make-literal-anchor
(redirect-target-element-alt-anchor i))
key))))) key)))))
(define (dest-path dest) (define (dest-path dest)
@ -287,17 +303,12 @@
(define/public (tag->path+anchor ri tag) (define/public (tag->path+anchor ri tag)
;; Called externally; not used internally ;; Called externally; not used internally
(let-values ([(dest ext?) (resolve-get/ext? #f ri tag)]) (let-values ([(dest ext?) (resolve-get/ext? #f ri tag)])
(if dest (cond [(not dest) (values #f #f)]
(if (and ext? external-tag-path) [(and ext? external-tag-path)
(values (values external-tag-path (format "~a" (serialize tag)))]
external-tag-path [else (values (relative->path (dest-path dest))
(format "~a" (serialize tag))) (and (not (dest-page? dest))
(values (anchor-name (dest-anchor dest))))])))
(relative->path (dest-path dest))
(if (dest-page? dest)
#f
(anchor-name (dest-anchor dest)))))
(values #f #f))))
;; ---------------------------------------- ;; ----------------------------------------
@ -308,69 +319,62 @@
null) null)
(define/public (render-toc-view d ri) (define/public (render-toc-view d ri)
(let-values ([(top mine) (define-values (top mine)
(let loop ([d d] [mine d]) (let loop ([d d] [mine d])
(let ([p (collected-info-parent (part-collected-info d ri))]) (let ([p (collected-info-parent (part-collected-info d ri))])
(if p (if p
(loop p (if (reveal-subparts? d) (loop p (if (reveal-subparts? d) mine d))
mine (values d mine)))))
d)) (define toc-content
(values d mine))))])
`((div ((class "tocset"))
,@(let ([toc-content
(map (lambda (pp) (map (lambda (pp)
(let ([p (car pp)] (let ([p (car pp)]
[show-number? (cdr pp)]) [show-number? (cdr pp)])
`(tr `(tr
(td (td ([align "right"])
((align "right"))
,@(if show-number? ,@(if show-number?
(format-number (collected-info-number (part-collected-info p ri)) (format-number (collected-info-number (part-collected-info p ri))
'((tt nbsp))) '((tt nbsp)))
'("-" nbsp))) '("-" nbsp)))
(td (td
(a ((href ,(let ([dest (resolve-get p ri (car (part-tags p)))]) (a ([href ,(let ([dest (resolve-get p ri (car (part-tags p)))])
(format "~a~a~a" (format "~a~a~a"
(from-root (relative->path (dest-path dest)) (from-root (relative->path (dest-path dest))
(get-dest-directory)) (get-dest-directory))
(if (dest-page? dest) "" "#")
(if (dest-page? dest) (if (dest-page? dest)
"" ""
"#") (anchor-name (dest-anchor dest)))))]
(if (dest-page? dest) [class ,(if (eq? p mine)
""
(anchor-name (dest-anchor dest))))))
(class ,(if (eq? p mine)
"tocviewselflink" "tocviewselflink"
"tocviewlink"))) "tocviewlink")])
,@(render-content (or (part-title-content p) '("???")) d ri)))))) ,@(render-content (or (part-title-content p) '("???"))
d ri))))))
(let loop ([l (map (lambda (v) (cons v #t)) (part-parts top))]) (let loop ([l (map (lambda (v) (cons v #t)) (part-parts top))])
(cond (cond [(null? l) null]
[(null? l) null]
[(reveal-subparts? (caar l)) [(reveal-subparts? (caar l))
(cons (car l) (loop (append (map (lambda (v) (cons v #f)) (cons (car l) (loop (append (map (lambda (v) (cons v #f))
(part-parts (caar l))) (part-parts (caar l)))
(cdr l))))] (cdr l))))]
[else (cons (car l) (loop (cdr l)))])))]) [else (cons (car l) (loop (cdr l)))]))))
(let* ([content (render-content `((div ([class "tocset"])
,@(let* ([content (render-content
(or (part-title-content top) '("???")) (or (part-title-content top) '("???"))
d ri)] d ri)]
[content (if (null? toc-content) [content (if (null? toc-content)
content content
`((a ((href "index.html") `((a ([href "index.html"] [class "tocviewlink"])
(class "tocviewlink"))
,@content)))]) ,@content)))])
`((div ((class "tocview")) `((div ([class "tocview"])
(div ((class "tocviewtitle")) ,@content) (div ([class "tocviewtitle"]) ,@content)
(div nbsp) (div nbsp)
,@(if (null? toc-content) ,@(if (null? toc-content)
'() '()
(toc-wrap (toc-wrap
`(table ((class "tocviewlist") (cellspacing "0")) `(table ([class "tocviewlist"] [cellspacing "0"])
,@toc-content))))))) ,@toc-content))))))
,@(render-onthispage-contents d ri top) ,@(render-onthispage-contents d ri top)
,@(parameterize ([extra-breaking? #t]) ,@(parameterize ([extra-breaking? #t])
(apply append (append-map (lambda (t)
(map (lambda (t)
(let loop ([t t]) (let loop ([t t])
(if (table? t) (if (table? t)
(render-table t d ri #f) (render-table t d ri #f)
@ -381,7 +385,7 @@
(pair? (table-flowss e))) (pair? (table-flowss e)))
(and (delayed-block? e) (and (delayed-block? e)
(loop (delayed-block-blocks e ri)))))) (loop (delayed-block-blocks e ri))))))
(flow-paragraphs (part-flow d)))))))))) (flow-paragraphs (part-flow d))))))))
(define/public (get-onthispage-label) (define/public (get-onthispage-label)
null) null)
@ -396,12 +400,9 @@
(let* ([nearly-top? (lambda (d) (nearly-top? d ri top))] (let* ([nearly-top? (lambda (d) (nearly-top? d ri top))]
[ps ((if (nearly-top? d) values cdr) [ps ((if (nearly-top? d) values cdr)
(let flatten ([d d]) (let flatten ([d d])
(apply (append*
append
;; don't include the section if it's in the TOC ;; don't include the section if it's in the TOC
(if (nearly-top? d) (if (nearly-top? d) null (list d))
null
(list d))
;; get internal targets: ;; get internal targets:
(letrec ([flow-targets (letrec ([flow-targets
(lambda (flow) (lambda (flow)
@ -420,10 +421,9 @@
[para-targets [para-targets
(lambda (para) (lambda (para)
(let loop ([c (paragraph-content para)]) (let loop ([c (paragraph-content para)])
(define a (and (pair? c) (car c)))
(cond (cond
[(null? c) null] [(null? c) null]
[else (let ([a (car c)])
(cond
[(toc-target-element? a) [(toc-target-element? a)
(cons a (loop (cdr c)))] (cons a (loop (cdr c)))]
[(toc-element? a) [(toc-element? a)
@ -437,34 +437,35 @@
[(part-relative-element? a) [(part-relative-element? a)
(loop (append (part-relative-element-content a ri) (loop (append (part-relative-element-content a ri)
(cdr c)))] (cdr c)))]
[else [else (loop (cdr c))])))]
(loop (cdr c))]))])))]
[table-targets [table-targets
(lambda (table) (lambda (table)
(apply append (append-map
(map (lambda (flows) (lambda (flows)
(apply append (map (lambda (f) (append-map
(lambda (f)
(if (eq? f 'cont) (if (eq? f 'cont)
null null
(flow-targets f))) (flow-targets f)))
flows))) flows))
(table-flowss table))))]) (table-flowss table)))])
(apply append (map block-targets (flow-paragraphs (part-flow d))))) (append-map block-targets
(flow-paragraphs (part-flow d))))
(map flatten (part-parts d)))))] (map flatten (part-parts d)))))]
[any-parts? (ormap part? ps)]) [any-parts? (ormap part? ps)])
(if (null? ps) (if (null? ps)
null null
`((div ((class "tocsub")) `((div ([class "tocsub"])
,@(get-onthispage-label) ,@(get-onthispage-label)
(table (table ([class "tocsublist"]
((class "tocsublist") [cellspacing "0"])
(cellspacing "0"))
,@(map (lambda (p) ,@(map (lambda (p)
`(tr `(tr
(td (td
,@(if (part? p) ,@(if (part? p)
`((span ((class "tocsublinknumber")) `((span ([class "tocsublinknumber"])
,@(format-number (collected-info-number ,@(format-number
(collected-info-number
(part-collected-info p ri)) (part-collected-info p ri))
'((tt nbsp))))) '((tt nbsp)))))
'("")) '(""))
@ -472,14 +473,14 @@
(render-content (toc-element-toc-content p) d ri) (render-content (toc-element-toc-content p) d ri)
(parameterize ([current-no-links #t] (parameterize ([current-no-links #t]
[extra-breaking? #t]) [extra-breaking? #t])
`((a ((href ,(if (part? p) `((a ([href ,(if (part? p)
(format "#~a" (anchor-name (tag-key (car (part-tags p)) ri))) (format "#~a" (anchor-name (tag-key (car (part-tags p)) ri)))
(format "#~a" (anchor-name (tag-key (target-element-tag p) ri))))) (format "#~a" (anchor-name (tag-key (target-element-tag p) ri))))]
(class ,(if (part? p) [class ,(if (part? p)
"tocsubseclink" "tocsubseclink"
(if any-parts? (if any-parts?
"tocsubnonseclink" "tocsubnonseclink"
"tocsublink")))) "tocsublink"))])
,@(if (part? p) ,@(if (part? p)
(render-content (or (part-title-content p) '("???")) d ri) (render-content (or (part-title-content p) '("???")) d ri)
(render-content (element-content p) d ri))))))))) (render-content (element-content p) d ri)))))))))
@ -488,60 +489,62 @@
(define/public (render-one-part d ri fn number) (define/public (render-one-part d ri fn number)
(parameterize ([current-output-file fn]) (parameterize ([current-output-file fn])
(let* ([style-file (or style-file scribble-css)] (let* ([style-file (or style-file scribble-css)]
[xpr `(html () ;; meta-stuff
(head [head `((meta ([http-equiv "content-type"]
(meta ((http-equiv "content-type") [content "text-html; charset=utf-8"])))]
(content "text-html; charset=utf-8"))) ;; css element (inlined or referenced)
,@(let ([c (part-title-content d)]) [head
(if c (cons (if (eq? 'inline css-path)
`((title ,@(format-number number '(nbsp))
,(content->string c this d ri)))
null))
,(if (eq? 'inline css-path)
`(style ([type "text/css"]) `(style ([type "text/css"])
"\n" "\n" ,(scribble-css-contents style-file) "\n")
,(with-input-from-file style-file `(link ([rel "stylesheet"]
(lambda () [type "text/css"]
;; note: file-size can be bigger that the [href ,(or css-path
;; string, but that's fine. (let-values
(read-string (file-size style-file)))) ([(base name dir?)
"\n")
`(link ((rel "stylesheet")
(type "text/css")
(href ,(or css-path
(let-values ([(base name dir?)
(split-path style-file)]) (split-path style-file)])
(path->string name)))) (path->string name)))]
(title "default"))))) [title "default"])))
(body ,@(render-toc-view d ri) head)]
(div ((class "maincolumn")) ;; title element
(div ((class "main")) [head (let ([c (part-title-content d)])
(if (not c)
head
(cons `(title ,@(format-number number '(nbsp))
,(content->string c this d ri))
head)))])
(unless css-path (install-file style-file))
(printf "<!DOCTYPE html PUBLIC ~s ~s>\n"
"-//W3C//DTD HTML 4.0 Transitional//EN"
"http://www.w3.org/TR/html4/loose.dtd")
(xml:write-xml/content
(xml:xexpr->xml
`(html ()
(head () ,@(reverse head))
(body () ,@(render-toc-view d ri)
(div ([class "maincolumn"])
(div ([class "main"])
(br)
,@(render-version d ri) ,@(render-version d ri)
,@(navigation d ri #f) ,@(navigation d ri #f)
,@(render-part d ri) ,@(render-part d ri)
,@(navigation d ri #t)))))]) ,@(navigation d ri #t))))))))))
(unless css-path
(install-file style-file))
(printf "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n")
(xml:write-xml/content (xml:xexpr->xml xpr)))))
(define/private (part-parent d ri) (define/private (part-parent d ri)
(collected-info-parent (part-collected-info d ri))) (collected-info-parent (part-collected-info d ri)))
(define/private (find-siblings d ri) (define/private (find-siblings d ri)
(let ([parent (collected-info-parent (part-collected-info d ri))]) (let ([parent (collected-info-parent (part-collected-info d ri))])
(let loop ([l (if parent (let loop ([l (cond
(part-parts parent) [parent (part-parts parent)]
(if (or (null? (part-parts d)) [(or (null? (part-parts d))
(not (part-whole-page? (car (part-parts d)) ri))) (not (part-whole-page? (car (part-parts d)) ri)))
(list d) (list d)]
(list d (car (part-parts d)))))] [else (list d (car (part-parts d)))])]
[prev #f]) [prev #f])
(cond (if (eq? (car l) d)
[(eq? (car l) d) (values prev (values prev (and (pair? (cdr l)) (cadr l)))
(and (pair? (cdr l)) (loop (cdr l) (car l))))))
(cadr l)))]
[else (loop (cdr l) (car l))]))))
(define contents-content '("contents")) (define contents-content '("contents"))
(define index-content '("index")) (define index-content '("index"))
@ -554,8 +557,8 @@
(define/public (derive-filename d) "bad.html") (define/public (derive-filename d) "bad.html")
(define/private (navigation d ri pre-space?) (define/private (navigation d ri pre-space?)
(define parent (part-parent d ri)) (let*-values ([(parent) (part-parent d ri)]
(let*-values ([(prev next) (find-siblings d ri)] [(prev next) (find-siblings d ri)]
[(prev) (if prev [(prev) (if prev
(let loop ([prev prev]) (let loop ([prev prev])
(if (and (toc-part? prev) (if (and (toc-part? prev)
@ -563,8 +566,7 @@
(loop (car (last-pair (part-parts prev)))) (loop (car (last-pair (part-parts prev))))
prev)) prev))
(and parent (toc-part? parent) parent))] (and parent (toc-part? parent) parent))]
[(next) (cond [(next) (cond [(and (toc-part? d)
[(and (toc-part? d)
(pair? (part-parts d))) (pair? (part-parts d)))
(car (part-parts d))] (car (part-parts d))]
[(and (not next) parent (toc-part? parent)) [(and (not next) parent (toc-part? parent))
@ -617,8 +619,7 @@
(if (or parent up-path) (if (or parent up-path)
(make-target-url (make-target-url
(if parent (if parent
(if (and (toc-part? parent) (if (and (toc-part? parent) (part-parent parent ri))
(part-parent parent ri))
(derive-filename parent) (derive-filename parent)
"index.html") "index.html")
up-path) up-path)
@ -639,23 +640,19 @@
(define/public (render-version d ri) (define/public (render-version d ri)
`((div ([class "versionbox"]) `((div ([class "versionbox"])
,@(render-content ,@(render-content
(list (list (make-element "version" (list "Version: " (current-version))))
(make-element "version"
(list "Version: "
(current-version))))
d d
ri)))) ri))))
(define/override (render-part d ri) (define/override (render-part d ri)
(let ([number (collected-info-number (part-collected-info d ri))]) (let ([number (collected-info-number (part-collected-info d ri))])
`(,@(if (and (not (part-title-content d)) `(,@(cond
(null? number)) [(and (not (part-title-content d)) (null? number)) null]
null [(part-style? d 'hidden)
(if (part-style? d 'hidden)
(map (lambda (t) (map (lambda (t)
`(a ((name ,(format "~a" (anchor-name (tag-key t ri))))))) `(a ((name ,(format "~a" (anchor-name (tag-key t ri)))))))
(part-tags d)) (part-tags d))]
`((,(case (length number) [else `((,(case (length number)
[(0) 'h2] [(0) 'h2]
[(1) 'h3] [(1) 'h3]
[(2) 'h4] [(2) 'h4]
@ -666,14 +663,13 @@
(part-tags d)) (part-tags d))
,@(if (part-title-content d) ,@(if (part-title-content d)
(render-content (part-title-content d) d ri) (render-content (part-title-content d) d ri)
null))))) null)))])
,@(render-flow* (part-flow d) d ri #f #f) ,@(render-flow* (part-flow d) d ri #f #f)
,@(let loop ([pos 1] ,@(let loop ([pos 1]
[secs (part-parts d)]) [secs (part-parts d)])
(if (null? secs) (if (null? secs)
null null
(append (append (render-part (car secs) ri)
(render-part (car secs) ri)
(loop (add1 pos) (cdr secs)))))))) (loop (add1 pos) (cdr secs))))))))
(define/private (render-flow* p part ri start-inline? special-last?) (define/private (render-flow* p part ri start-inline? special-last?)
@ -683,21 +679,19 @@
(cond (cond
[(null? f) null] [(null? f) null]
[(and (table? (car f)) [(and (table? (car f))
(or (not special-last?) (or (not special-last?) (not (null? (cdr f)))))
(not (null? (cdr f)))))
(cons `(p ,@(render-block (car f) part ri inline?)) (cons `(p ,@(render-block (car f) part ri inline?))
(loop (cdr f) #f))] (loop (cdr f) #f))]
[else [else (append (render-block (car f) part ri inline?)
(append (render-block (car f) part ri inline?)
(loop (cdr f) #f))]))) (loop (cdr f) #f))])))
(define/override (render-flow p part ri start-inline?) (define/override (render-flow p part ri start-inline?)
(render-flow* p part ri start-inline? #t)) (render-flow* p part ri start-inline? #t))
(define/override (render-paragraph p part ri) (define/override (render-paragraph p part ri)
`((p ,@(if (styled-paragraph? p) `((p ,(if (styled-paragraph? p)
`(((class ,(styled-paragraph-style p)))) `([class ,(styled-paragraph-style p)])
null) `())
,@(super render-paragraph p part ri)))) ,@(super render-paragraph p part ri))))
(define/override (render-element e part ri) (define/override (render-element e part ri)
@ -707,12 +701,11 @@
[(target-element? e) [(target-element? e)
`((a ((name ,(format "~a" (anchor-name (tag-key (target-element-tag e) ri)))))) `((a ((name ,(format "~a" (anchor-name (tag-key (target-element-tag e) ri))))))
,@(render-plain-element e part ri))] ,@(render-plain-element e part ri))]
[(and (link-element? e) [(and (link-element? e) (not (current-no-links)))
(not (current-no-links)))
(parameterize ([current-no-links #t]) (parameterize ([current-no-links #t])
(let-values ([(dest ext?) (resolve-get/ext? part ri (link-element-tag e))]) (let-values ([(dest ext?) (resolve-get/ext? part ri (link-element-tag e))])
(if dest (if dest
`((a ((href ,(if (and ext? external-tag-path) `((a [(href ,(if (and ext? external-tag-path)
;; Redirected to search: ;; Redirected to search:
(format "~a;tag=~a" (format "~a;tag=~a"
external-tag-path external-tag-path
@ -723,15 +716,13 @@
(format "~a~a~a" (format "~a~a~a"
(from-root (relative->path (dest-path dest)) (from-root (relative->path (dest-path dest))
(get-dest-directory)) (get-dest-directory))
(if (dest-page? dest) (if (dest-page? dest) "" "#")
""
"#")
(if (dest-page? dest) (if (dest-page? dest)
"" ""
(anchor-name (dest-anchor dest)))))) (anchor-name (dest-anchor dest))))))
,@(if (string? (element-style e)) ,@(if (string? (element-style e))
`((class ,(element-style e))) `([class ,(element-style e)])
null)) null)]
,@(if (null? (element-content e)) ,@(if (null? (element-content e))
(render-content (strip-aux (dest-title dest)) part ri) (render-content (strip-aux (dest-title dest)) part ri)
(render-content (element-content e) part ri)))) (render-content (element-content e) part ri))))
@ -740,15 +731,14 @@
(fprintf (current-error-port) (fprintf (current-error-port)
"Undefined link: ~s~n" "Undefined link: ~s~n"
(tag-key (link-element-tag e) ri))) (tag-key (link-element-tag e) ri)))
`((font ((class "badlink")) `((font ([class "badlink"])
,@(if (null? (element-content e)) ,@(if (null? (element-content e))
`(,(format "~s" (tag-key (link-element-tag e) ri))) `(,(format "~s" (tag-key (link-element-tag e) ri)))
(render-plain-element e part ri))))))))] (render-plain-element e part ri))))))))]
[else (render-plain-element e part ri)])) [else (render-plain-element e part ri)]))
(define/private (render-plain-element e part ri) (define/private (render-plain-element e part ri)
(let ([style (and (element? e) (let ([style (and (element? e) (element-style e))])
(element-style e))])
(cond (cond
[(symbol? style) [(symbol? style)
(case style (case style
@ -774,34 +764,36 @@
(andmap byte? (cdr style))) (andmap byte? (cdr style)))
(and (= 2 (length style)) (and (= 2 (length style))
(member (cadr style) (member (cadr style)
'("white" "black" "red" "green" "blue" "cyan" "magenta" "yellow"))))) '("white" "black" "red" "green" "blue"
"cyan" "magenta" "yellow")))))
(error 'render-font "bad color style: ~e" style)) (error 'render-font "bad color style: ~e" style))
`((font ((style ,(format "~acolor: ~a" `((font ([style ,(format "~acolor: ~a"
(if (eq? (car style) 'bg-color) (if (eq? (car style) 'bg-color)
"background-" "background-"
"") "")
(if (= 2 (length style)) (if (= 2 (length style))
(cadr style) (cadr style)
(apply string-append "#" (string-append*
(map (lambda (v) (let ([s (format "0~x" v)]) "#"
(map (lambda (v)
(let ([s (format "0~x" v)])
(substring s (- (string-length s) 2)))) (substring s (- (string-length s) 2))))
(cdr style))))))) (cdr style)))))])
,@(super render-element e part ri)))] ,@(super render-element e part ri)))]
[(target-url? style) [(target-url? style)
(if (current-no-links) (if (current-no-links)
(super render-element e part ri) (super render-element e part ri)
(parameterize ([current-no-links #t]) (parameterize ([current-no-links #t])
`((a ((href ,(let ([addr (target-url-addr style)]) `((a ([href ,(let ([addr (target-url-addr style)])
(if (path? addr) (if (path? addr)
(from-root addr (from-root addr (get-dest-directory))
(get-dest-directory)) addr))]
addr)))
,@(if (string? (target-url-style style)) ,@(if (string? (target-url-style style))
`((class ,(target-url-style style))) `([class ,(target-url-style style)])
null)) null))
,@(super render-element e part ri)))))] ,@(super render-element e part ri)))))]
[(url-anchor? style) [(url-anchor? style)
`((a ((name ,(url-anchor-name style))) `((a ([name ,(url-anchor-name style)])
,@(super render-element e part ri)))] ,@(super render-element e part ri)))]
[(image-file? style) [(image-file? style)
(let* ([src (main-collects-relative->path (image-file-path style))] (let* ([src (main-collects-relative->path (image-file-path style))]
@ -819,41 +811,39 @@
(number->string (number->string
(inexact->exact (inexact->exact
(floor (* scale (integer-bytes->integer s #f #t))))))]) (floor (* scale (integer-bytes->integer s #f #t))))))])
`((width ,(to-num w)) `([width ,(to-num w)]
(height ,(to-num h)))) [height ,(to-num h)]))
null))))]) null))))])
`((img ((src ,(let ([p (install-file src)]) `((img ([src ,(let ([p (install-file src)])
(if (path? p) (if (path? p)
(url->string (path->url (path->complete-path p))) (url->string (path->url (path->complete-path p)))
p)))) p))])
,@sz)))] ,@sz)))]
[else (super render-element e part ri)]))) [else (super render-element e part ri)])))
(define/override (render-table t part ri need-inline?) (define/override (render-table t part ri need-inline?)
(define index? (eq? 'index (table-style t))) (define index? (eq? 'index (table-style t)))
`(,@(if index? `(,search-script ,search-field) '()) `(,@(if index? `(,search-script ,search-field) '())
(table ((cellspacing "0") (table ([cellspacing "0"]
,@(if need-inline? ,@(if need-inline?
'((style "display: inline; vertical-align: top;")) '([style "display: inline; vertical-align: top;"])
null) null)
,@(case (table-style t) ,@(case (table-style t)
[(boxed) '((class "boxed"))] [(boxed) '([class "boxed"])]
[(centered) '((align "center"))] [(centered) '([align "center"])]
[(at-right) '((align "right"))] [(at-right) '([align "right"])]
[(at-left) '((align "left"))] [(at-left) '([align "left"])]
[else null]) [else null])
,@(let ([a (and (list? (table-style t)) ,@(let ([a (and (list? (table-style t))
(assoc 'style (table-style t)))]) (assoc 'style (table-style t)))])
(if (and a (string? (cadr a))) (if (and a (string? (cadr a)))
`((class ,(cadr a))) `([class ,(cadr a)])
null)) null))
,@(if (string? (table-style t)) ,@(if (string? (table-style t))
`((class ,(table-style t))) `([class ,(table-style t)])
null)) null))
,@(map (lambda (flows style) ,@(map (lambda (flows style)
`(tr (,@(if style `(tr (,@(if style `([class ,style]) null))
`((class ,style))
null))
,@(let loop ([ds flows] ,@(let loop ([ds flows]
[as (cdr (or (and (list? (table-style t)) [as (cdr (or (and (list? (table-style t))
(assoc 'alignment (or (table-style t) null))) (assoc 'alignment (or (table-style t) null)))
@ -862,19 +852,20 @@
(cdr (or (and (list? (table-style t)) (cdr (or (and (list? (table-style t))
(assoc 'valignment (or (table-style t) null))) (assoc 'valignment (or (table-style t) null)))
(cons #f (map (lambda (x) #f) flows))))]) (cons #f (map (lambda (x) #f) flows))))])
(if (null? ds) (cond
null [(null? ds) null]
(if (eq? (car ds) 'cont) [(eq? (car ds) 'cont)
(loop (cdr ds) (cdr as) (cdr vas)) (loop (cdr ds) (cdr as) (cdr vas))]
[else
(let ([d (car ds)] (let ([d (car ds)]
[a (car as)] [a (car as)]
[va (car vas)]) [va (car vas)])
(cons (cons
`(td (,@(case a `(td (,@(case a
[(#f) null] [(#f) null]
[(right) '((align "right"))] [(right) '([align "right"])]
[(center) '((align "center"))] [(center) '([align "center"])]
[(left) '((align "left"))]) [(left) '([align "left"])])
,@(case va ,@(case va
[(#f) null] [(#f) null]
[(top) '((valign "top"))] [(top) '((valign "top"))]
@ -882,39 +873,35 @@
[(bottom) '((valign "bottom"))]) [(bottom) '((valign "bottom"))])
,@(if (and (pair? (cdr ds)) ,@(if (and (pair? (cdr ds))
(eq? 'cont (cadr ds))) (eq? 'cont (cadr ds)))
`((colspan `([colspan
,(number->string ,(number->string
(let loop ([n 2] (let loop ([n 2]
[ds (cddr ds)]) [ds (cddr ds)])
(cond (cond
[(null? ds) n] [(null? ds) n]
[(eq? 'cont (car ds)) (loop (+ n 1) (cdr ds))] [(eq? 'cont (car ds)) (loop (+ n 1) (cdr ds))]
[else n]))))) [else n])))])
null)) null))
,@(render-flow d part ri #f)) ,@(render-flow d part ri #f))
(loop (cdr ds) (cdr as) (cdr vas))))))))) (loop (cdr ds) (cdr as) (cdr vas))))]))))
(table-flowss t) (table-flowss t)
(cdr (or (and (list? (table-style t)) (cdr (or (and (list? (table-style t))
(assoc 'row-styles (or (table-style t) null))) (assoc 'row-styles (or (table-style t) null)))
(cons #f (map (lambda (x) #f) (table-flowss t))))))))) (cons #f (map (lambda (x) #f) (table-flowss t)))))))))
(define/override (render-blockquote t part ri) (define/override (render-blockquote t part ri)
`((blockquote ,@(if (string? (blockquote-style t)) `((blockquote ,(if (string? (blockquote-style t))
`(((class ,(blockquote-style t)))) `([class ,(blockquote-style t)])
null) `())
,@(apply append ,@(append-map (lambda (i) (render-block i part ri #f))
(map (lambda (i) (blockquote-paragraphs t)))))
(render-block i part ri #f))
(blockquote-paragraphs t))))))
(define/override (render-itemization t part ri) (define/override (render-itemization t part ri)
`((ul `((ul ,(if (and (styled-itemization? t)
,@(if (and (styled-itemization? t)
(string? (styled-itemization-style t))) (string? (styled-itemization-style t)))
`(((class ,(styled-itemization-style t)))) `([class ,(styled-itemization-style t)])
null) `())
,@(map (lambda (flow) ,@(map (lambda (flow) `(li ,@(render-flow flow part ri #t)))
`(li ,@(render-flow flow part ri #t)))
(itemization-flows t))))) (itemization-flows t)))))
(define/override (render-other i part ri) (define/override (render-other i part ri)
@ -924,13 +911,13 @@
(regexp-match-positions #rx"[-:/+_]|[a-z](?=[A-Z])" i))]) (regexp-match-positions #rx"[-:/+_]|[a-z](?=[A-Z])" i))])
(if m (if m
(list* (substring i 0 (cdar m)) (list* (substring i 0 (cdar m))
;; Most browsers wrap after a hyphen. The ;; Most browsers wrap after a hyphen. The one that
;; one that doesn't, Firefox, pays attention ;; doesn't, Firefox, pays attention to wbr. Some
;; to wbr. Some browsers ignore wbr, but ;; browsers ignore wbr, but at least they don't do
;; at least they don't do strange things with it. ;; strange things with it.
(if (equal? #\- (string-ref i (caar m))) (if (equal? #\- (string-ref i (caar m)))
'(wbr) '(wbr)
`(span ((class "mywbr")) " ")) `(span ([class "mywbr"]) " "))
(render-other (substring i (cdar m)) part ri)) (render-other (substring i (cdar m)) part ri))
(ascii-ize i)))] (ascii-ize i)))]
[(eq? i 'mdash) `(" " ndash " ")] [(eq? i 'mdash) `(" " ndash " ")]
@ -970,36 +957,34 @@
(super get-dest-directory))) (super get-dest-directory)))
(define/override (derive-filename d) (define/override (derive-filename d)
(let ([fn (format "~a.html" (regexp-replace* (let ([fn (format "~a.html"
(regexp-replace*
"[^-a-zA-Z0-9_=]" "[^-a-zA-Z0-9_=]"
(let ([s (cadr (car (part-tags d)))]) (let ([s (cadr (car (part-tags d)))])
(if (string? s) (cond [(string? s) s]
s [(part-title-content d)
(if (part-title-content d) (content->string (part-title-content d))]
(content->string (part-title-content d)) [else
;; last-ditch effort to make up a unique name: ;; last-ditch effort to make up a unique name:
(format "???~a" (eq-hash-code d))))) (format "???~a" (eq-hash-code d))]))
"_"))]) "_"))])
(when ((string-length fn) . >= . 48) (when ((string-length fn) . >= . 48)
(error "file name too long (need a tag):" fn)) (error "file name too long (need a tag):" fn))
fn)) fn))
(define/override (collect ds fns) (define/override (collect ds fns)
(super collect ds (map (lambda (fn) (super collect ds (map (lambda (fn) (build-path fn "index.html")) fns)))
(build-path fn "index.html"))
fns)))
(define/override (current-part-whole-page? d) (define/override (current-part-whole-page? d)
((collecting-sub) . <= . 2)) ((collecting-sub) . <= . 2))
(define/override (collect-part d parent ci number) (define/override (collect-part d parent ci number)
(let ([prev-sub (collecting-sub)]) (let ([prev-sub (collecting-sub)])
(parameterize ([collecting-sub (if (toc-part? d) (parameterize ([collecting-sub (if (toc-part? d) 1 (add1 prev-sub))])
1
(add1 prev-sub))])
(if (= 1 prev-sub) (if (= 1 prev-sub)
(let ([filename (derive-filename d)]) (let ([filename (derive-filename d)])
(parameterize ([current-output-file (build-path (path-only (current-output-file)) (parameterize ([current-output-file
(build-path (path-only (current-output-file))
filename)]) filename)])
(super collect-part d parent ci number))) (super collect-part d parent ci number)))
(super collect-part d parent ci number))))) (super collect-part d parent ci number)))))
@ -1012,10 +997,8 @@
(make-directory fn)) (make-directory fn))
(parameterize ([current-subdirectory (file-name-from-path fn)]) (parameterize ([current-subdirectory (file-name-from-path fn)])
(let ([fn (build-path fn "index.html")]) (let ([fn (build-path fn "index.html")])
(with-output-to-file fn (with-output-to-file fn #:exists 'truncate/replace
#:exists 'truncate/replace (lambda () (render-one d ri fn))))))
(lambda ()
(render-one d ri fn))))))
ds ds
fns)) fns))
@ -1023,8 +1006,7 @@
(eq? top (collected-info-parent (part-collected-info d ri)))) (eq? top (collected-info-parent (part-collected-info d ri))))
(define/override (get-onthispage-label) (define/override (get-onthispage-label)
`((div ((class "tocsubtitle")) `((div ([class "tocsubtitle"]) "On this page:")))
"On this page:")))
(define/override (toc-wrap p) (define/override (toc-wrap p)
(list p)) (list p))
@ -1039,27 +1021,23 @@
(versioned-part-version d) (versioned-part-version d)
(current-version))]) (current-version))])
(let ([number (collected-info-number (part-collected-info d ri))]) (let ([number (collected-info-number (part-collected-info d ri))])
(cond (if (and (not (on-separate-page))
[(and (not (on-separate-page))
(or (= 1 (length number)) (or (= 1 (length number))
(next-separate-page))) (next-separate-page)))
;; Render as just a link, and put the actual ;; Render as just a link, and put the actual content in a
;; content in a new file: ;; new file:
(let* ([filename (derive-filename d)] (let* ([filename (derive-filename d)]
[full-path (build-path (path-only (current-output-file)) [full-path (build-path (path-only (current-output-file))
filename)]) filename)])
(parameterize ([on-separate-page #t]) (parameterize ([on-separate-page #t])
(with-output-to-file full-path (with-output-to-file full-path #:exists 'truncate/replace
#:exists 'truncate/replace (lambda () (render-one-part d ri full-path number)))
(lambda () null))
(render-one-part d ri full-path number)))
null))]
[else
(let ([sep? (on-separate-page)]) (let ([sep? (on-separate-page)])
(parameterize ([next-separate-page (toc-part? d)] (parameterize ([next-separate-page (toc-part? d)]
[on-separate-page #f]) [on-separate-page #f])
;; Normal section render ;; Normal section render
(super render-part d ri)))])))) (super render-part d ri)))))))
(super-new))) (super-new)))
@ -1071,13 +1049,11 @@
(url->string (path->url (path->complete-path p))) (url->string (path->url (path->complete-path p)))
(let ([e-d (explode (path->complete-path d (current-directory)))] (let ([e-d (explode (path->complete-path d (current-directory)))]
[e-p (explode (path->complete-path p (current-directory)))]) [e-p (explode (path->complete-path p (current-directory)))])
(let loop ([e-d e-d] (let loop ([e-d e-d] [e-p e-p])
[e-p e-p])
(cond (cond
[(null? e-d) [(null? e-d)
(let loop ([e-p e-p]) (let loop ([e-p e-p])
(cond (cond [(null? e-p) "/"]
[(null? e-p) "/"]
[(null? (cdr e-p)) (car e-p)] [(null? (cdr e-p)) (car e-p)]
[(eq? 'same (car e-p)) (loop (cdr e-p))] [(eq? 'same (car e-p)) (loop (cdr e-p))]
[(eq? 'up (car e-p)) (string-append "../" (loop (cdr e-p)))] [(eq? 'up (car e-p)) (string-append "../" (loop (cdr e-p)))]
@ -1085,8 +1061,7 @@
[(equal? (car e-d) (car e-p)) (loop (cdr e-d) (cdr e-p))] [(equal? (car e-d) (car e-p)) (loop (cdr e-d) (cdr e-p))]
[(eq? 'same (car e-d)) (loop (cdr e-d) e-p)] [(eq? 'same (car e-d)) (loop (cdr e-d) e-p)]
[(eq? 'same (car e-p)) (loop e-d (cdr e-p))] [(eq? 'same (car e-p)) (loop e-d (cdr e-p))]
[else (string-append [else (string-append (string-append* (map (lambda (x) "../") e-d))
(apply string-append (map (lambda (x) "../") e-d))
(loop null e-p))]))))) (loop null e-p))])))))
(define (explode p) (define (explode p)
@ -1099,4 +1074,4 @@
name)]) name)])
(if (path? base) (if (path? base)
(cons name (loop base)) (cons name (loop base))
(list name)))))))) (list name)))))))