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