commit 65865c81bd6434ffa0bae5fc82dec62c60f4b86e
parent 841c313163c1de867fc5c04abc9ee924efdcf77b
Author: Eli Barzilay <eli@racket-lang.org>
Date: Mon, 12 May 2008 08:12:54 +0000
misc improvements
svn: r9812
original commit: c0d028e4bc3ff8907084c74b42c802bfe344abc9
Diffstat:
1 file changed, 1056 insertions(+), 1081 deletions(-)
diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss
@@ -1,1102 +1,1077 @@
-
-(module html-render scheme/base
- (require "struct.ss"
- scheme/class
- scheme/path
- scheme/file
- mzlib/runtime-path
- setup/main-doc
- setup/main-collects
- mzlib/list
- net/url
- net/base64
- scheme/serialize
- (prefix-in xml: xml/xml)
- (for-syntax scheme/base)
- "search.ss")
- (provide render-mixin
- render-multi-mixin)
-
- (xml:empty-tag-shorthand xml:html-empty-tags)
-
- (define-runtime-path scribble-css "scribble.css")
-
- (define current-subdirectory (make-parameter #f))
- (define current-output-file (make-parameter #f))
- (define current-top-part (make-parameter #f))
- (define on-separate-page (make-parameter #t))
- (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))
- (define current-version (make-parameter (version)))
-
- (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
- ;; codecs) by using "~" followed by a hex encoding.
- (define (anchor-name v)
- (if (literal-anchor? v)
- (literal-anchor-string v)
- (let loop ([s (format "~a" v)])
- (cond
- [(regexp-match-positions #rx"[A-Z.]" s)
- => (lambda (m)
- (string-append
- (loop (substring s 0 (caar m)))
- "."
- (substring s (caar m) (cdar m))
- (loop (substring s (cdar m)))))]
- [(regexp-match-positions #rx"[^-a-zA-Z0-9_!*'().]" s)
- => (lambda (m)
- (string-append
- (substring s 0 (caar m))
- "~"
- (format "~x" (char->integer (string-ref s (caar m))))
- (loop (substring s (cdar m)))))]
- [else s]))))
-
- (define-serializable-struct literal-anchor (string))
-
- (define literal
- (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"))
- ,(apply literal
- `("\n"
- ,@(map (lambda (x) (if (string? x) x (format "~a" x))) body)
- "\n"))))
-
- #reader scribble/reader (begin ; easier to format
-
- (define search-script
- @script{
- var search_nodes = null;
- var last_search_terms = null;
- function node_to_text(node) {
- if (node.nodeType == 3) return node.nodeValue;
- var r = "";
- var children = node.childNodes;
- for (var i=0@";" i<children.length@";" i++) {
- r = r + node_to_text(children[i]);
- }
- return r;
+#lang scheme/base
+
+(require "struct.ss"
+ scheme/class
+ scheme/path
+ scheme/file
+ scheme/list
+ scheme/string
+ mzlib/runtime-path
+ setup/main-doc
+ setup/main-collects
+ net/url
+ net/base64
+ scheme/serialize
+ (prefix-in xml: xml/xml)
+ (for-syntax scheme/base)
+ "search.ss")
+(provide render-mixin
+ render-multi-mixin)
+
+(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))
+(define current-top-part (make-parameter #f))
+(define on-separate-page (make-parameter #t))
+(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))
+(define current-version (make-parameter (version)))
+
+(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
+;; codecs) by using "~" followed by a hex encoding.
+(define (anchor-name v)
+ (if (literal-anchor? v)
+ (literal-anchor-string v)
+ (let loop ([s (format "~a" v)])
+ (cond
+ [(regexp-match-positions #rx"[A-Z.]" s)
+ => (lambda (m)
+ (string-append
+ (loop (substring s 0 (caar m)))
+ "."
+ (substring s (caar m) (cdar m))
+ (loop (substring s (cdar m)))))]
+ [(regexp-match-positions #rx"[^-a-zA-Z0-9_!*'().]" s)
+ => (lambda (m)
+ (string-append
+ (substring s 0 (caar m))
+ "~"
+ (format "~x" (char->integer (string-ref s (caar m))))
+ (loop (substring s (cdar m)))))]
+ [else s]))))
+
+(define-serializable-struct literal-anchor (string))
+
+(define literal
+ (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"])
+ ,(apply literal
+ `("\n"
+ ,@(map (lambda (x) (if (string? x) x (format "~a" x))) body)
+ "\n"))))
+
+#reader scribble/reader (begin ; easier to format
+
+(define search-script
+ @script{
+ var search_nodes = null;
+ var last_search_terms = null;
+ function node_to_text(node) {
+ if (node.nodeType == 3) return node.nodeValue;
+ var r = "";
+ var children = node.childNodes;
+ for (var i=0@";" i<children.length@";" i++) {
+ r = r + node_to_text(children[i]);
}
- var search_box = null;
- function initialize_search() {
- var all_links = document.getElementsByTagName("a");
- search_nodes = new Array();
- for (var i=0@";" i<all_links.length@";" i++)
- if (all_links[i].className == "indexlink") {
- all_links[i].flat_text = node_to_text(all_links[i]).toLowerCase();
- search_nodes.push(all_links[i]);
- }
- search_box = document.getElementById("search_box");
- if (location.search.length > 0) {
- var paramstrs = location.search.substring(1).split(/[@";"&]/);
- for (var i in paramstrs) {
- var param = paramstrs[i].split(/=/);
- if (param.length == 2 && param[0] == "q") {
- search_box.value = unescape(param[1]).replace(/\+/g," ");
- break;
- }
+ return r;
+ }
+ var search_box = null;
+ function initialize_search() {
+ var all_links = document.getElementsByTagName("a");
+ search_nodes = new Array();
+ for (var i=0@";" i<all_links.length@";" i++)
+ if (all_links[i].className == "indexlink") {
+ all_links[i].flat_text = node_to_text(all_links[i]).toLowerCase();
+ search_nodes.push(all_links[i]);
+ }
+ search_box = document.getElementById("search_box");
+ if (location.search.length > 0) {
+ var paramstrs = location.search.substring(1).split(/[@";"&]/);
+ for (var i in paramstrs) {
+ var param = paramstrs[i].split(/=/);
+ if (param.length == 2 && param[0] == "q") {
+ search_box.value = unescape(param[1]).replace(/\+/g," ");
+ break;
}
}
- if (search_box.value != "") do_search(search_box.value);
- search_box.focus();
- search_box.select();
}
- window.onload = initialize_search;
- function do_search(terms) {
- terms = terms.toLowerCase();
- if (terms == last_search_terms) return;
- last_search_terms = terms;
- terms = terms.split(/ +/);
- var none = true;
- for (var i=0@";" i<search_nodes.length@";" i++) {
- var show = true, curtext = search_nodes[i].flat_text;
- for (var j=0@";" j<terms.length@";" j++) {
- if (terms[j] != "" && curtext.indexOf(terms[j]) < 0) {
- show = false;
- break;
- }
+ if (search_box.value != "") do_search(search_box.value);
+ search_box.focus();
+ search_box.select();
+ }
+ window.onload = initialize_search;
+ function do_search(terms) {
+ terms = terms.toLowerCase();
+ if (terms == last_search_terms) return;
+ last_search_terms = terms;
+ terms = terms.split(/ +/);
+ var none = true;
+ for (var i=0@";" i<search_nodes.length@";" i++) {
+ var show = true, curtext = search_nodes[i].flat_text;
+ for (var j=0@";" j<terms.length@";" j++) {
+ if (terms[j] != "" && curtext.indexOf(terms[j]) < 0) {
+ show = false;
+ break;
}
- if (show) none = false;
- var style = search_nodes[i].style;
- var newdisp = show ? "block" : "none";
- if (newdisp != style.display) style.display = newdisp;
}
- search_box.style.backgroundColor = none ? "#ffe0e0" : "white";
+ if (show) none = false;
+ var style = search_nodes[i].style;
+ var newdisp = show ? "block" : "none";
+ if (newdisp != style.display) style.display = newdisp;
}
- var search_timer = null;
- function delayed_search(str, event) {
- if (event && event.keyCode == 13) {
- do_search(str);
- } else {
- if (search_timer != null) {
- var t = search_timer;
- search_timer = null;
- clearTimeout(t);
- }
- search_timer = setTimeout(function(){do_search(str)@";"}, 1000);
+ search_box.style.backgroundColor = none ? "#ffe0e0" : "white";
+ }
+ var search_timer = null;
+ function delayed_search(str, event) {
+ if (event && event.keyCode == 13) {
+ do_search(str);
+ } else {
+ if (search_timer != null) {
+ var t = search_timer;
+ search_timer = null;
+ clearTimeout(t);
}
- }})
+ search_timer = setTimeout(function(){do_search(str)@";"}, 1000);
+ }
+ }})
- (define search-field
- @`p{Search: @(input ((type "text") (id "search_box")
- (onchange "delayed_search(this.value,event);")
- (onkeyup "delayed_search(this.value,event);")))})
+(define search-field
+ @`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])
+(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...\"; }"))))))
-
- )
-
- ;; ----------------------------------------
- ;; main mixin
-
- (define (render-mixin %)
- (class %
- (inherit render-content
- render-block
- collect-part
- install-file
- get-dest-directory
- format-number
- quiet-table-of-contents)
-
- (init-field [css-path #f]
- [up-path #f]
- [style-file #f])
-
- (define/override (get-suffix) #".html")
-
- (define/override (index-manual-newlines?)
- #t)
-
- ;; ----------------------------------------
-
- (inherit path->root-relative
- root-relative->path)
-
- (define (path->relative p)
- (let ([p (path->main-doc-relative p)])
- (if (path? p)
- (let ([p (path->main-collects-relative p)])
- (if (path? p)
- (path->root-relative p)
- (intern-taglet p)))
- (intern-taglet p))))
-
- (define (relative->path p)
- (let ([p (main-doc-relative->path p)])
- (if (path? p)
+ " this.value=\"...search...\"; }")]))))
+
+)
+
+;; ----------------------------------------
+;; main mixin
+
+(define (render-mixin %)
+ (class %
+ (inherit render-content
+ render-block
+ collect-part
+ install-file
+ get-dest-directory
+ format-number
+ quiet-table-of-contents)
+
+ (init-field [css-path #f]
+ [up-path #f]
+ [style-file #f])
+
+ (define/override (get-suffix) #".html")
+
+ (define/override (index-manual-newlines?)
+ #t)
+
+ ;; ----------------------------------------
+
+ (inherit path->root-relative
+ root-relative->path)
+
+ (define (path->relative p)
+ (let ([p (path->main-doc-relative p)])
+ (if (path? p)
+ (let ([p (path->main-collects-relative p)])
+ (if (path? p)
+ (path->root-relative p)
+ (intern-taglet p)))
+ (intern-taglet p))))
+
+ (define (relative->path p)
+ (let ([p (main-doc-relative->path p)])
+ (if (path? p)
+ p
+ (let ([p (main-collects-relative->path p)])
+ (if (path? p)
p
- (let ([p (main-collects-relative->path p)])
- (if (path? p)
- p
- (root-relative->path p))))))
-
- ;; ----------------------------------------
-
- (define/override (start-collect ds fns ci)
- (map (lambda (d fn)
- (parameterize ([current-output-file fn]
- [current-top-part d])
- (collect-part d #f ci null)))
- ds
- fns))
-
- (define/public (part-whole-page? p ri)
- (let ([dest (resolve-get p ri (car (part-tags p)))])
- (dest-page? dest)))
-
- (define/public (current-part-whole-page? d)
- (eq? d (current-top-part)))
-
- (define/override (collect-part-tags d ci number)
- (for ([t (part-tags d)])
- (let ([key (generate-tag t ci)])
- (collect-put! ci key
- (vector (and (current-output-file)
- (path->relative (current-output-file)))
- (or (part-title-content d) '("???"))
- (current-part-whole-page? d)
- key)))))
-
- (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)])
- (if (redirect-target-element? i)
- (let-values ([(base name dir?) (split-path p)])
- (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))
- key)))))
-
- (define (dest-path dest)
- (if (vector? dest) ; temporary
- (vector-ref dest 0)
- (list-ref dest 0)))
- (define (dest-title dest)
- (if (vector? dest)
- (vector-ref dest 1)
- (list-ref dest 1)))
- (define (dest-page? dest)
- (if (vector? dest)
- (vector-ref dest 2)
- (list-ref dest 2)))
- (define (dest-anchor dest)
- (if (vector? dest)
- (vector-ref dest 3)
- (list-ref dest 3)))
-
- ;; ----------------------------------------
-
- (define external-tag-path #f)
- (define/public (set-external-tag-path p)
- (set! external-tag-path p))
-
- (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))))
-
- ;; ----------------------------------------
-
- (define/private (reveal-subparts? p)
- (part-style? p 'reveal))
-
- (define/public (toc-wrap table)
- null)
-
- (define/public (render-toc-view d ri)
- (let-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
- (map (lambda (pp)
- (let ([p (car pp)]
- [show-number? (cdr pp)])
- `(tr
- (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)))])
- (format "~a~a~a"
- (from-root (relative->path (dest-path dest))
- (get-dest-directory))
- (if (dest-page? dest)
- ""
- "#")
- (if (dest-page? dest)
- ""
- (anchor-name (dest-anchor dest))))))
- (class ,(if (eq? p mine)
- "tocviewselflink"
- "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]
- [(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
- (or (part-title-content top) '("???"))
- d ri)]
- [content (if (null? toc-content)
- content
- `((a ((href "index.html")
- (class "tocviewlink"))
- ,@content)))])
- `((div ((class "tocview"))
- (div ((class "tocviewtitle")) ,@content)
- (div nbsp)
- ,@(if (null? toc-content)
- '()
- (toc-wrap
- `(table ((class "tocviewlist") (cellspacing "0"))
- ,@toc-content)))))))
- ,@(render-onthispage-contents d ri top)
- ,@(parameterize ([extra-breaking? #t])
- (apply append
- (map (lambda (t)
- (let loop ([t t])
- (if (table? t)
- (render-table t d ri #f)
- (loop (delayed-block-blocks t ri)))))
- (filter (lambda (e)
- (let loop ([e e])
- (or (and (auxiliary-table? e)
- (pair? (table-flowss e)))
- (and (delayed-block? e)
- (loop (delayed-block-blocks e ri))))))
- (flow-paragraphs (part-flow d))))))))))
-
- (define/public (get-onthispage-label)
- null)
-
- (define/public (nearly-top? d ri top)
- #f)
-
- (define/private (render-onthispage-contents d ri top)
- (if (ormap (lambda (p) (part-whole-page? p ri))
- (part-parts d))
- null
- (let* ([nearly-top? (lambda (d) (nearly-top? d ri top))]
- [ps ((if (nearly-top? d) values cdr)
- (let flatten ([d d])
- (apply
- append
- ;; don't include the section if it's in the TOC
- (if (nearly-top? d)
- null
- (list d))
- ;; get internal targets:
- (letrec ([flow-targets
- (lambda (flow)
- (apply append (map block-targets (flow-paragraphs flow))))]
- [block-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 block-targets (blockquote-paragraphs e)))]
- [(delayed-block? e)
- null]))]
- [para-targets
- (lambda (para)
- (let loop ([c (paragraph-content para)])
- (cond
- [(null? c) null]
- [else (let ([a (car c)])
- (cond
- [(toc-target-element? a)
- (cons a (loop (cdr c)))]
- [(toc-element? a)
- (cons a (loop (cdr c)))]
- [(element? a)
- (append (loop (element-content a))
- (loop (cdr c)))]
- [(delayed-element? a)
- (loop (append (delayed-element-content a ri)
- (cdr c)))]
- [(part-relative-element? a)
- (loop (append (part-relative-element-content a ri)
- (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 block-targets (flow-paragraphs (part-flow d)))))
- (map flatten (part-parts d)))))]
- [any-parts? (ormap part? ps)])
- (if (null? ps)
- null
- `((div ((class "tocsub"))
- ,@(get-onthispage-label)
- (table
- ((class "tocsublist")
- (cellspacing "0"))
- ,@(map (lambda (p)
- `(tr
- (td
- ,@(if (part? p)
- `((span ((class "tocsublinknumber"))
- ,@(format-number (collected-info-number
- (part-collected-info p ri))
- '((tt nbsp)))))
- '(""))
- ,@(if (toc-element? p)
- (render-content (toc-element-toc-content p) d ri)
- (parameterize ([current-no-links #t]
- [extra-breaking? #t])
- `((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)
- "tocsubseclink"
- (if any-parts?
- "tocsubnonseclink"
- "tocsublink"))))
- ,@(if (part? p)
- (render-content (or (part-title-content p) '("???")) d ri)
- (render-content (element-content p) d ri)))))))))
- ps))))))))
-
- (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)
- `(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?)
- (split-path style-file)])
- (path->string name))))
- (title "default")))))
- (body ,@(render-toc-view d ri)
- (div ((class "maincolumn"))
- (div ((class "main"))
- ,@(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)))))
-
- (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))
- (not (part-whole-page? (car (part-parts d)) ri)))
- (list d)
- (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))]))))
-
- (define contents-content '("contents"))
- (define index-content '("index"))
- (define prev-content '(larr " prev"))
- (define up-content '("up"))
- (define next-content '("next " rarr))
- (define no-next-content next-content)
- (define sep-element (make-element #f '(nbsp nbsp)))
-
- (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)]
- [(prev) (if prev
- (let loop ([prev prev])
- (if (and (toc-part? prev)
- (pair? (part-parts prev)))
- (loop (car (last-pair (part-parts prev))))
- prev))
- (and parent (toc-part? parent) parent))]
- [(next) (cond
- [(and (toc-part? d)
- (pair? (part-parts d)))
- (car (part-parts d))]
- [(and (not next) parent (toc-part? parent))
- (let-values ([(prev next)
- (find-siblings parent ri)])
- next)]
- [else next])]
- [(index) (let loop ([d d])
- (let ([p (part-parent d ri)])
- (if p
- (loop p)
- (let ([subs (part-parts d)])
- (and (pair? subs)
- (let ([d (car (last-pair subs))])
- (and (part-style? d 'index)
- d)))))))])
- (define (render . content)
- (render-content content d ri))
- (if (not (or prev next parent index up-path))
+ (root-relative->path p))))))
+
+ ;; ----------------------------------------
+
+ (define/override (start-collect ds fns ci)
+ (map (lambda (d fn)
+ (parameterize ([current-output-file fn]
+ [current-top-part d])
+ (collect-part d #f ci null)))
+ ds
+ fns))
+
+ (define/public (part-whole-page? p ri)
+ (let ([dest (resolve-get p ri (car (part-tags p)))])
+ (dest-page? dest)))
+
+ (define/public (current-part-whole-page? d)
+ (eq? d (current-top-part)))
+
+ (define/override (collect-part-tags d ci number)
+ (for ([t (part-tags d)])
+ (let ([key (generate-tag t ci)])
+ (collect-put! ci key
+ (vector (and (current-output-file)
+ (path->relative (current-output-file)))
+ (or (part-title-content d) '("???"))
+ (current-part-whole-page? d)
+ key)))))
+
+ (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)])
+ (if (redirect-target-element? i)
+ (let-values ([(base name dir?) (split-path p)])
+ (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))
+ key)))))
+
+ (define (dest-path dest)
+ (if (vector? dest) ; temporary
+ (vector-ref dest 0)
+ (list-ref dest 0)))
+ (define (dest-title dest)
+ (if (vector? dest)
+ (vector-ref dest 1)
+ (list-ref dest 1)))
+ (define (dest-page? dest)
+ (if (vector? dest)
+ (vector-ref dest 2)
+ (list-ref dest 2)))
+ (define (dest-anchor dest)
+ (if (vector? dest)
+ (vector-ref dest 3)
+ (list-ref dest 3)))
+
+ ;; ----------------------------------------
+
+ (define external-tag-path #f)
+ (define/public (set-external-tag-path p)
+ (set! external-tag-path p))
+
+ (define/public (tag->path+anchor ri tag)
+ ;; Called externally; not used internally
+ (let-values ([(dest ext?) (resolve-get/ext? #f ri tag)])
+ (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))))])))
+
+ ;; ----------------------------------------
+
+ (define/private (reveal-subparts? p)
+ (part-style? p 'reveal))
+
+ (define/public (toc-wrap table)
+ null)
+
+ (define/public (render-toc-view d ri)
+ (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)))))
+ (define toc-content
+ (map (lambda (pp)
+ (let ([p (car pp)]
+ [show-number? (cdr pp)])
+ `(tr
+ (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)))])
+ (format "~a~a~a"
+ (from-root (relative->path (dest-path dest))
+ (get-dest-directory))
+ (if (dest-page? dest) "" "#")
+ (if (dest-page? dest)
+ ""
+ (anchor-name (dest-anchor dest)))))]
+ [class ,(if (eq? p mine)
+ "tocviewselflink"
+ "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]
+ [(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)))]))))
+ `((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"])
+ ,@content)))])
+ `((div ([class "tocview"])
+ (div ([class "tocviewtitle"]) ,@content)
+ (div nbsp)
+ ,@(if (null? toc-content)
+ '()
+ (toc-wrap
+ `(table ([class "tocviewlist"] [cellspacing "0"])
+ ,@toc-content))))))
+ ,@(render-onthispage-contents d ri top)
+ ,@(parameterize ([extra-breaking? #t])
+ (append-map (lambda (t)
+ (let loop ([t t])
+ (if (table? t)
+ (render-table t d ri #f)
+ (loop (delayed-block-blocks t ri)))))
+ (filter (lambda (e)
+ (let loop ([e e])
+ (or (and (auxiliary-table? e)
+ (pair? (table-flowss e)))
+ (and (delayed-block? e)
+ (loop (delayed-block-blocks e ri))))))
+ (flow-paragraphs (part-flow d))))))))
+
+ (define/public (get-onthispage-label)
+ null)
+
+ (define/public (nearly-top? d ri top)
+ #f)
+
+ (define/private (render-onthispage-contents d ri top)
+ (if (ormap (lambda (p) (part-whole-page? p ri))
+ (part-parts d))
+ null
+ (let* ([nearly-top? (lambda (d) (nearly-top? d ri top))]
+ [ps ((if (nearly-top? d) values cdr)
+ (let flatten ([d d])
+ (append*
+ ;; don't include the section if it's in the TOC
+ (if (nearly-top? d) null (list d))
+ ;; get internal targets:
+ (letrec ([flow-targets
+ (lambda (flow)
+ (apply append (map block-targets (flow-paragraphs flow))))]
+ [block-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 block-targets (blockquote-paragraphs e)))]
+ [(delayed-block? e)
+ null]))]
+ [para-targets
+ (lambda (para)
+ (let loop ([c (paragraph-content para)])
+ (define a (and (pair? c) (car c)))
+ (cond
+ [(null? c) null]
+ [(toc-target-element? a)
+ (cons a (loop (cdr c)))]
+ [(toc-element? a)
+ (cons a (loop (cdr c)))]
+ [(element? a)
+ (append (loop (element-content a))
+ (loop (cdr c)))]
+ [(delayed-element? a)
+ (loop (append (delayed-element-content a ri)
+ (cdr c)))]
+ [(part-relative-element? a)
+ (loop (append (part-relative-element-content a ri)
+ (cdr c)))]
+ [else (loop (cdr c))])))]
+ [table-targets
+ (lambda (table)
+ (append-map
+ (lambda (flows)
+ (append-map
+ (lambda (f)
+ (if (eq? f 'cont)
+ null
+ (flow-targets f)))
+ 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
- `(,@(if pre-space? '((p nbsp)) null)
- (div ([class "navleft"])
- ,@(render (make-element
- (if parent
- (make-target-url "index.html" #f)
- "nonavigation")
- contents-content))
- ,@(if index
- `(nbsp
- ,@(render (if (eq? d index)
- (make-element "nonavigation" index-content)
- (make-link-element
- #f index-content (car (part-tags index)))))
- ,@(if (eq? d index)
- null
- `((small nbsp
- ,(search-index-box (derive-filename index))))))
- null))
- (div ([class "navright"])
- ,@(render
- (make-element
- (if parent
- (make-target-url
- (if prev (derive-filename prev) "index.html")
- #f)
- "nonavigation")
- prev-content)
- sep-element
- (make-element
- (if (or parent up-path)
- (make-target-url
- (if parent
- (if (and (toc-part? parent)
- (part-parent parent ri))
- (derive-filename parent)
- "index.html")
- up-path)
- #f)
- "nonavigation")
- up-content)
- sep-element
- (make-element
- (if next
- (make-target-url (derive-filename next) #f)
- "nonavigation")
- next-content)))
- (p nbsp)))))
-
- (define/override (render-one d ri fn)
- (render-one-part d ri fn null))
-
- (define/public (render-version d ri)
- `((div ([class "versionbox"])
- ,@(render-content
- (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)
- (map (lambda (t)
- `(a ((name ,(format "~a" (anchor-name (tag-key t ri)))))))
- (part-tags d))
- `((,(case (length number)
- [(0) 'h2]
- [(1) 'h3]
- [(2) 'h4]
- [else 'h5])
- ,@(format-number number '((tt nbsp)))
- ,@(map (lambda (t)
- `(a ((name ,(format "~a" (anchor-name (tag-key t ri)))))))
- (part-tags d))
- ,@(if (part-title-content d)
- (render-content (part-title-content d) d ri)
- 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)
- (loop (add1 pos) (cdr secs))))))))
-
- (define/private (render-flow* p part ri start-inline? special-last?)
- ;; Wrap each table with <p>, except for a trailing table
- ;; when `special-last?' is #t
- (let loop ([f (flow-paragraphs p)][inline? start-inline?])
- (cond
- [(null? f) null]
- [(and (table? (car 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?)
- (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)
- ,@(super render-paragraph p part ri))))
-
- (define/override (render-element e part ri)
+ `((div ([class "tocsub"])
+ ,@(get-onthispage-label)
+ (table ([class "tocsublist"]
+ [cellspacing "0"])
+ ,@(map (lambda (p)
+ `(tr
+ (td
+ ,@(if (part? p)
+ `((span ([class "tocsublinknumber"])
+ ,@(format-number
+ (collected-info-number
+ (part-collected-info p ri))
+ '((tt nbsp)))))
+ '(""))
+ ,@(if (toc-element? p)
+ (render-content (toc-element-toc-content p) d ri)
+ (parameterize ([current-no-links #t]
+ [extra-breaking? #t])
+ `((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)
+ "tocsubseclink"
+ (if any-parts?
+ "tocsubnonseclink"
+ "tocsublink"))])
+ ,@(if (part? p)
+ (render-content (or (part-title-content p) '("???")) d ri)
+ (render-content (element-content p) d ri)))))))))
+ ps))))))))
+
+ (define/public (render-one-part d ri fn number)
+ (parameterize ([current-output-file fn])
+ (let* ([style-file (or style-file scribble-css)]
+ ;; 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" ,(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"])))
+ 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))))))))))
+
+ (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 (cond
+ [parent (part-parts parent)]
+ [(or (null? (part-parts d))
+ (not (part-whole-page? (car (part-parts d)) ri)))
+ (list d)]
+ [else (list d (car (part-parts d)))])]
+ [prev #f])
+ (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"))
+ (define prev-content '(larr " prev"))
+ (define up-content '("up"))
+ (define next-content '("next " rarr))
+ (define no-next-content next-content)
+ (define sep-element (make-element #f '(nbsp nbsp)))
+
+ (define/public (derive-filename d) "bad.html")
+
+ (define/private (navigation d ri pre-space?)
+ (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)
+ (pair? (part-parts prev)))
+ (loop (car (last-pair (part-parts prev))))
+ prev))
+ (and parent (toc-part? parent) parent))]
+ [(next) (cond [(and (toc-part? d)
+ (pair? (part-parts d)))
+ (car (part-parts d))]
+ [(and (not next) parent (toc-part? parent))
+ (let-values ([(prev next)
+ (find-siblings parent ri)])
+ next)]
+ [else next])]
+ [(index) (let loop ([d d])
+ (let ([p (part-parent d ri)])
+ (if p
+ (loop p)
+ (let ([subs (part-parts d)])
+ (and (pair? subs)
+ (let ([d (car (last-pair subs))])
+ (and (part-style? d 'index)
+ d)))))))])
+ (define (render . content)
+ (render-content content d ri))
+ (if (not (or prev next parent index up-path))
+ null
+ `(,@(if pre-space? '((p nbsp)) null)
+ (div ([class "navleft"])
+ ,@(render (make-element
+ (if parent
+ (make-target-url "index.html" #f)
+ "nonavigation")
+ contents-content))
+ ,@(if index
+ `(nbsp
+ ,@(render (if (eq? d index)
+ (make-element "nonavigation" index-content)
+ (make-link-element
+ #f index-content (car (part-tags index)))))
+ ,@(if (eq? d index)
+ null
+ `((small nbsp
+ ,(search-index-box (derive-filename index))))))
+ null))
+ (div ([class "navright"])
+ ,@(render
+ (make-element
+ (if parent
+ (make-target-url
+ (if prev (derive-filename prev) "index.html")
+ #f)
+ "nonavigation")
+ prev-content)
+ sep-element
+ (make-element
+ (if (or parent up-path)
+ (make-target-url
+ (if parent
+ (if (and (toc-part? parent) (part-parent parent ri))
+ (derive-filename parent)
+ "index.html")
+ up-path)
+ #f)
+ "nonavigation")
+ up-content)
+ sep-element
+ (make-element
+ (if next
+ (make-target-url (derive-filename next) #f)
+ "nonavigation")
+ next-content)))
+ (p nbsp)))))
+
+ (define/override (render-one d ri fn)
+ (render-one-part d ri fn null))
+
+ (define/public (render-version d ri)
+ `((div ([class "versionbox"])
+ ,@(render-content
+ (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))])
+ `(,@(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))]
+ [else `((,(case (length number)
+ [(0) 'h2]
+ [(1) 'h3]
+ [(2) 'h4]
+ [else 'h5])
+ ,@(format-number number '((tt nbsp)))
+ ,@(map (lambda (t)
+ `(a ((name ,(format "~a" (anchor-name (tag-key t ri)))))))
+ (part-tags d))
+ ,@(if (part-title-content d)
+ (render-content (part-title-content d) d ri)
+ 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)
+ (loop (add1 pos) (cdr secs))))))))
+
+ (define/private (render-flow* p part ri start-inline? special-last?)
+ ;; Wrap each table with <p>, except for a trailing table
+ ;; when `special-last?' is #t
+ (let loop ([f (flow-paragraphs p)][inline? start-inline?])
(cond
- [(hover-element? e)
- `((span ((title ,(hover-element-text e))) ,@(render-plain-element e part ri)))]
- [(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)))
- (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)
- ;; Redirected to search:
- (format "~a;tag=~a"
- external-tag-path
- (base64-encode
- (string->bytes/utf-8
- (format "~a" (serialize (link-element-tag e))))))
- ;; Normal link:
- (format "~a~a~a"
- (from-root (relative->path (dest-path dest))
- (get-dest-directory))
- (if (dest-page? dest)
- ""
- "#")
- (if (dest-page? dest)
- ""
- (anchor-name (dest-anchor dest))))))
- ,@(if (string? (element-style e))
- `((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))))
- (begin
- (when #f
- (fprintf (current-error-port)
- "Undefined link: ~s~n"
- (tag-key (link-element-tag e) ri)))
- `((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))])
- (cond
- [(symbol? style)
- (case style
- [(italic) `((i ,@(super render-element e part ri)))]
- [(bold) `((b ,@(super render-element e part ri)))]
- [(tt) `((span ([class "stt"]) ,@(super render-element e part ri)))]
- [(no-break) `((span ([class "nobreak"]) ,@(super render-element e part ri)))]
- [(sf) `((b (font ([size "-1"][face "Helvetica"]) ,@(super render-element e part ri))))]
- [(subscript) `((sub ,@(super render-element e part ri)))]
- [(superscript) `((sup ,@(super render-element e part ri)))]
- [(hspace) `((span ([class "hspace"])
- ,@(let ([str (content->string (element-content e))])
- (map (lambda (c) 'nbsp) (string->list str)))))]
- [(newline) `((br))]
- [else (error 'html-render "unrecognized style symbol: ~e" style)])]
- [(string? style)
- `((span ([class ,style]) ,@(super render-element e part ri)))]
- [(and (pair? style)
- (or (eq? (car style) 'bg-color)
- (eq? (car style) 'color)))
- (unless (and (list? style)
- (or (and (= 4 (length style))
- (andmap byte? (cdr style)))
- (and (= 2 (length style))
- (member (cadr style)
- '("white" "black" "red" "green" "blue" "cyan" "magenta" "yellow")))))
- (error 'render-font "bad color style: ~e" style))
- `((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)])
- (substring s (- (string-length s) 2))))
- (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)])
- (if (path? addr)
- (from-root addr
- (get-dest-directory))
- addr)))
- ,@(if (string? (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)))
- ,@(super render-element e part ri)))]
- [(image-file? style)
- (let* ([src (main-collects-relative->path (image-file-path style))]
- [scale (image-file-scale style)]
- [sz (if (= 1.0 scale)
- null
- ;; Try to extract file size:
- (call-with-input-file*
- src
- (lambda (in)
- (if (regexp-try-match #px#"^\211PNG.{12}" in)
- (let ([w (read-bytes 4 in)]
- [h (read-bytes 4 in)]
- [to-num (lambda (s)
- (number->string
- (inexact->exact
- (floor (* scale (integer-bytes->integer s #f #t))))))])
- `((width ,(to-num w))
- (height ,(to-num h))))
- null))))])
- `((img ((src ,(let ([p (install-file src)])
- (if (path? p)
- (url->string (path->url (path->complete-path 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")
- ,@(if need-inline?
- '((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"))]
- [else null])
- ,@(let ([a (and (list? (table-style t))
- (assoc 'style (table-style t)))])
- (if (and a (string? (cadr a)))
- `((class ,(cadr a)))
- null))
- ,@(if (string? (table-style t))
- `((class ,(table-style t)))
- null))
- ,@(map (lambda (flows style)
- `(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)))
- (cons #f (map (lambda (x) #f) flows))))]
- [vas
- (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))
- (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"))])
- ,@(case va
- [(#f) null]
- [(top) '((valign "top"))]
- [(baseline) '((valign "baseline"))]
- [(bottom) '((valign "bottom"))])
- ,@(if (and (pair? (cdr ds))
- (eq? 'cont (cadr ds)))
- `((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])))))
- null))
- ,@(render-flow d part ri #f))
- (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))))))
-
- (define/override (render-itemization t part ri)
- `((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)))
- (itemization-flows t)))))
-
- (define/override (render-other i part ri)
+ [(null? f) null]
+ [(and (table? (car 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?)
+ (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)])
+ `())
+ ,@(super render-paragraph p part ri))))
+
+ (define/override (render-element e part ri)
+ (cond
+ [(hover-element? e)
+ `((span ((title ,(hover-element-text e))) ,@(render-plain-element e part ri)))]
+ [(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)))
+ (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)
+ ;; Redirected to search:
+ (format "~a;tag=~a"
+ external-tag-path
+ (base64-encode
+ (string->bytes/utf-8
+ (format "~a" (serialize (link-element-tag e))))))
+ ;; Normal link:
+ (format "~a~a~a"
+ (from-root (relative->path (dest-path dest))
+ (get-dest-directory))
+ (if (dest-page? dest) "" "#")
+ (if (dest-page? dest)
+ ""
+ (anchor-name (dest-anchor dest))))))
+ ,@(if (string? (element-style e))
+ `([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))))
+ (begin
+ (when #f
+ (fprintf (current-error-port)
+ "Undefined link: ~s~n"
+ (tag-key (link-element-tag e) ri)))
+ `((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))])
(cond
- [(string? i)
- (let ([m (and (extra-breaking?)
- (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.
- (if (equal? #\- (string-ref i (caar m)))
- '(wbr)
- `(span ((class "mywbr")) " "))
- (render-other (substring i (cdar m)) part ri))
- (ascii-ize i)))]
- [(eq? i 'mdash) `(" " ndash " ")]
- [(symbol? i) (list i)]
- [else (list (format "~s" i))]))
-
- (define/private (ascii-ize s)
- (let ([m (regexp-match-positions #rx"[^\u01-\u7E]" s)])
- (if m
- (append (ascii-ize (substring s 0 (caar m)))
- (list (char->integer (string-ref s (caar m))))
- (ascii-ize (substring s (cdar m))))
- (list s))))
-
- ;; ----------------------------------------
-
- (super-new)))
-
- ;; ----------------------------------------
- ;; multi-file output
-
- (define (render-multi-mixin %)
- (class %
- (inherit render-one
- render-one-part
- render-content
- part-whole-page?
- format-number)
-
- (inherit-field report-output?)
-
- (define/override (get-suffix) #"")
-
- (define/override (get-dest-directory)
- (or (and (current-subdirectory)
- (build-path (or (super get-dest-directory) (current-directory)) (current-subdirectory)))
- (super get-dest-directory)))
-
- (define/override (derive-filename d)
- (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))
- ;; last-ditch effort to make up a unique name:
- (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)))
-
- (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))])
- (if (= 1 prev-sub)
- (let ([filename (derive-filename d)])
- (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)))))
-
- (define/override (render ds fns ri)
- (map (lambda (d fn)
- (when report-output?
- (printf " [Output to ~a/index.html]\n" fn))
- (unless (directory-exists? fn)
- (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))))))
- ds
- fns))
-
- (define/override (nearly-top? d ri top)
- (eq? top (collected-info-parent (part-collected-info d ri))))
-
- (define/override (get-onthispage-label)
- `((div ((class "tocsubtitle"))
- "On this page:")))
-
- (define/override (toc-wrap p)
- (list p))
-
- (inherit render-table
- render-paragraph)
-
- (define/override (render-part d ri)
- (parameterize ([current-version
- (if (and (versioned-part? d)
- (versioned-part-version d))
- (versioned-part-version d)
- (current-version))])
- (let ([number (collected-info-number (part-collected-info d ri))])
- (cond
- [(and (not (on-separate-page))
+ [(symbol? style)
+ (case style
+ [(italic) `((i ,@(super render-element e part ri)))]
+ [(bold) `((b ,@(super render-element e part ri)))]
+ [(tt) `((span ([class "stt"]) ,@(super render-element e part ri)))]
+ [(no-break) `((span ([class "nobreak"]) ,@(super render-element e part ri)))]
+ [(sf) `((b (font ([size "-1"][face "Helvetica"]) ,@(super render-element e part ri))))]
+ [(subscript) `((sub ,@(super render-element e part ri)))]
+ [(superscript) `((sup ,@(super render-element e part ri)))]
+ [(hspace) `((span ([class "hspace"])
+ ,@(let ([str (content->string (element-content e))])
+ (map (lambda (c) 'nbsp) (string->list str)))))]
+ [(newline) `((br))]
+ [else (error 'html-render "unrecognized style symbol: ~e" style)])]
+ [(string? style)
+ `((span ([class ,style]) ,@(super render-element e part ri)))]
+ [(and (pair? style)
+ (or (eq? (car style) 'bg-color)
+ (eq? (car style) 'color)))
+ (unless (and (list? style)
+ (or (and (= 4 (length style))
+ (andmap byte? (cdr style)))
+ (and (= 2 (length style))
+ (member (cadr style)
+ '("white" "black" "red" "green" "blue"
+ "cyan" "magenta" "yellow")))))
+ (error 'render-font "bad color style: ~e" style))
+ `((font ([style ,(format "~acolor: ~a"
+ (if (eq? (car style) 'bg-color)
+ "background-"
+ "")
+ (if (= 2 (length style))
+ (cadr style)
+ (string-append*
+ "#"
+ (map (lambda (v)
+ (let ([s (format "0~x" v)])
+ (substring s (- (string-length s) 2))))
+ (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)])
+ (if (path? addr)
+ (from-root addr (get-dest-directory))
+ addr))]
+ ,@(if (string? (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)])
+ ,@(super render-element e part ri)))]
+ [(image-file? style)
+ (let* ([src (main-collects-relative->path (image-file-path style))]
+ [scale (image-file-scale style)]
+ [sz (if (= 1.0 scale)
+ null
+ ;; Try to extract file size:
+ (call-with-input-file*
+ src
+ (lambda (in)
+ (if (regexp-try-match #px#"^\211PNG.{12}" in)
+ (let ([w (read-bytes 4 in)]
+ [h (read-bytes 4 in)]
+ [to-num (lambda (s)
+ (number->string
+ (inexact->exact
+ (floor (* scale (integer-bytes->integer s #f #t))))))])
+ `([width ,(to-num w)]
+ [height ,(to-num h)]))
+ null))))])
+ `((img ([src ,(let ([p (install-file src)])
+ (if (path? p)
+ (url->string (path->url (path->complete-path 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"]
+ ,@(if need-inline?
+ '([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"])]
+ [else null])
+ ,@(let ([a (and (list? (table-style t))
+ (assoc 'style (table-style t)))])
+ (if (and a (string? (cadr a)))
+ `([class ,(cadr a)])
+ null))
+ ,@(if (string? (table-style t))
+ `([class ,(table-style t)])
+ null))
+ ,@(map (lambda (flows style)
+ `(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)))
+ (cons #f (map (lambda (x) #f) flows))))]
+ [vas
+ (cdr (or (and (list? (table-style t))
+ (assoc 'valignment (or (table-style t) null)))
+ (cons #f (map (lambda (x) #f) flows))))])
+ (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"])])
+ ,@(case va
+ [(#f) null]
+ [(top) '((valign "top"))]
+ [(baseline) '((valign "baseline"))]
+ [(bottom) '((valign "bottom"))])
+ ,@(if (and (pair? (cdr ds))
+ (eq? 'cont (cadr ds)))
+ `([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])))])
+ null))
+ ,@(render-flow d part ri #f))
+ (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)])
+ `())
+ ,@(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)
+ (string? (styled-itemization-style 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)
+ (cond
+ [(string? i)
+ (let ([m (and (extra-breaking?)
+ (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.
+ (if (equal? #\- (string-ref i (caar m)))
+ '(wbr)
+ `(span ([class "mywbr"]) " "))
+ (render-other (substring i (cdar m)) part ri))
+ (ascii-ize i)))]
+ [(eq? i 'mdash) `(" " ndash " ")]
+ [(symbol? i) (list i)]
+ [else (list (format "~s" i))]))
+
+ (define/private (ascii-ize s)
+ (let ([m (regexp-match-positions #rx"[^\u01-\u7E]" s)])
+ (if m
+ (append (ascii-ize (substring s 0 (caar m)))
+ (list (char->integer (string-ref s (caar m))))
+ (ascii-ize (substring s (cdar m))))
+ (list s))))
+
+ ;; ----------------------------------------
+
+ (super-new)))
+
+;; ----------------------------------------
+;; multi-file output
+
+(define (render-multi-mixin %)
+ (class %
+ (inherit render-one
+ render-one-part
+ render-content
+ part-whole-page?
+ format-number)
+
+ (inherit-field report-output?)
+
+ (define/override (get-suffix) #"")
+
+ (define/override (get-dest-directory)
+ (or (and (current-subdirectory)
+ (build-path (or (super get-dest-directory) (current-directory)) (current-subdirectory)))
+ (super get-dest-directory)))
+
+ (define/override (derive-filename d)
+ (let ([fn (format "~a.html"
+ (regexp-replace*
+ "[^-a-zA-Z0-9_=]"
+ (let ([s (cadr (car (part-tags 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))]))
+ "_"))])
+ (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)))
+
+ (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))])
+ (if (= 1 prev-sub)
+ (let ([filename (derive-filename d)])
+ (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)))))
+
+ (define/override (render ds fns ri)
+ (map (lambda (d fn)
+ (when report-output?
+ (printf " [Output to ~a/index.html]\n" fn))
+ (unless (directory-exists? fn)
+ (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))))))
+ ds
+ fns))
+
+ (define/override (nearly-top? d ri top)
+ (eq? top (collected-info-parent (part-collected-info d ri))))
+
+ (define/override (get-onthispage-label)
+ `((div ([class "tocsubtitle"]) "On this page:")))
+
+ (define/override (toc-wrap p)
+ (list p))
+
+ (inherit render-table
+ render-paragraph)
+
+ (define/override (render-part d ri)
+ (parameterize ([current-version
+ (if (and (versioned-part? d)
+ (versioned-part-version d))
+ (versioned-part-version d)
+ (current-version))])
+ (let ([number (collected-info-number (part-collected-info d ri))])
+ (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:
- (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
- (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-new)))
-
- ;; ----------------------------------------
- ;; utils
-
- (define (from-root p d)
- (if (not d)
- (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])
- (cond
- [(null? e-d)
- (let loop ([e-p 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)))]
- [else (string-append (car e-p) "/" (loop (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-p)) (loop e-d (cdr e-p))]
- [else (string-append
- (apply string-append (map (lambda (x) "../") e-d))
- (loop null e-p))])))))
-
- (define (explode p)
- (reverse (let loop ([p p])
- (let-values ([(base name dir?) (split-path p)])
- (let ([name (if base
- (if (path? name)
- (path-element->string name)
- name)
- name)])
- (if (path? base)
- (cons name (loop base))
- (list name))))))))
+ ;; 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))
+ (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-new)))
+
+;; ----------------------------------------
+;; utils
+
+(define (from-root p d)
+ (if (not d)
+ (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])
+ (cond
+ [(null? e-d)
+ (let loop ([e-p 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)))]
+ [else (string-append (car e-p) "/" (loop (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-p)) (loop e-d (cdr e-p))]
+ [else (string-append (string-append* (map (lambda (x) "../") e-d))
+ (loop null e-p))])))))
+
+(define (explode p)
+ (reverse (let loop ([p p])
+ (let-values ([(base name dir?) (split-path p)])
+ (let ([name (if base
+ (if (path? name)
+ (path-element->string name)
+ name)
+ name)])
+ (if (path? base)
+ (cons name (loop base))
+ (list name)))))))
