diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index bca5fe1f..94b595d2 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -1,1102 +1,1077 @@ +#lang scheme/base -(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) +(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) +(xml:empty-tag-shorthand xml:html-empty-tags) - (define-runtime-path scribble-css "scribble.css") +(define-runtime-path scribble-css "scribble.css") +(define scribble-css-contents + (let* ([read-file + (lambda (file) + (with-input-from-file file + (lambda () + ;; note: file-size can be bigger than the string, but + ;; that's fine. + (read-string (file-size file)))))] + [file-getter + (lambda (default-file) + (let ([c #f]) + (lambda (file) + (if (or (not file) (equal? file default-file)) + (begin (unless c (set! c (read-file default-file))) c) + (read-file file)))))]) + (file-getter scribble-css))) - (define current-subdirectory (make-parameter #f)) - (define current-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 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)) +(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])))) +;; 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-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")))) +(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 +#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 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 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=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...\"; }")])))) - ) +) - ;; ---------------------------------------- - ;; main mixin +;; ---------------------------------------- +;; main mixin - (define (render-mixin %) - (class % - (inherit render-content - render-block - collect-part - install-file - get-dest-directory - format-number - quiet-table-of-contents) +(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]) + (init-field [css-path #f] + [up-path #f] + [style-file #f]) - (define/override (get-suffix) #".html") + (define/override (get-suffix) #".html") - (define/override (index-manual-newlines?) - #t) + (define/override (index-manual-newlines?) + #t) - ;; ---------------------------------------- + ;; ---------------------------------------- - (inherit path->root-relative - root-relative->path) + (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) + (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)))))) + (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/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 (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/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-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/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 (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 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) - (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/private (reveal-subparts? p) + (part-style? p 'reveal)) - (define/public (get-onthispage-label) - null) + (define/public (toc-wrap table) + null) - (define/public (nearly-top? d ri top) - #f) + (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/private (render-onthispage-contents d ri top) - (if (ormap (lambda (p) (part-whole-page? p ri)) - (part-parts 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 - (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)))))))) + `((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 "\n") - (xml:write-xml/content (xml:xexpr->xml xpr))))) + (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 "\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 (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/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 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/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)) - 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)))))) + (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

, 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)]) + `()) + ,@(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 + [(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)) - (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))))) + ,@(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-one d ri fn) - (render-one-part d ri fn null)) + (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/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

, 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) - (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) + (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))))) + `([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/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)))) - - ;; ---------------------------------------- + (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 + (super-new))) - (define (render-multi-mixin %) - (class % - (inherit render-one - render-one-part - render-content - part-whole-page? - format-number) +;; ---------------------------------------- +;; multi-file output - (inherit-field report-output?) +(define (render-multi-mixin %) + (class % + (inherit render-one + render-one-part + render-content + part-whole-page? + format-number) - (define/override (get-suffix) #"") + (inherit-field report-output?) - (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 (get-suffix) #"") - (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 (get-dest-directory) + (or (and (current-subdirectory) + (build-path (or (super get-dest-directory) (current-directory)) (current-subdirectory))) + (super get-dest-directory))) - (define/override (collect ds fns) - (super collect ds (map (lambda (fn) - (build-path fn "index.html")) - fns))) + (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 (current-part-whole-page? d) - ((collecting-sub) . <= . 2)) + (define/override (collect ds fns) + (super collect ds (map (lambda (fn) (build-path fn "index.html")) fns))) - (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 (current-part-whole-page? d) + ((collecting-sub) . <= . 2)) - (define/override (nearly-top? d ri top) - (eq? top (collected-info-parent (part-collected-info d ri)))) + (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 (get-onthispage-label) - `((div ((class "tocsubtitle")) - "On this page:"))) - - (define/override (toc-wrap p) - (list p)) + (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)) - (inherit render-table - render-paragraph) + (define/override (nearly-top? d ri top) + (eq? top (collected-info-parent (part-collected-info d ri)))) - (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)) + (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)))])))) + ;; 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))) + (super-new))) - ;; ---------------------------------------- - ;; utils +;; ---------------------------------------- +;; 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 (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)))))))) +(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)))))))