b7afb3cf8f
For example, if you make a multi-column table with a `racketblock' in each column, then the columns size to fit the code --- instead of forcing the table width to match the page width and forcing each column to take an equal share width.
1570 lines
68 KiB
Racket
1570 lines
68 KiB
Racket
#lang scheme/base
|
|
|
|
(require "core.rkt"
|
|
"private/render-utils.rkt"
|
|
"html-properties.rkt"
|
|
scheme/class
|
|
scheme/path
|
|
scheme/file
|
|
scheme/port
|
|
scheme/list
|
|
scheme/string
|
|
file/convertible
|
|
mzlib/runtime-path
|
|
setup/main-doc
|
|
setup/main-collects
|
|
setup/dirs
|
|
net/url
|
|
net/base64
|
|
scheme/serialize
|
|
(prefix-in xml: xml/xml)
|
|
(for-syntax scheme/base)
|
|
"search.rkt"
|
|
(except-in "base.rkt" url))
|
|
(provide render-mixin
|
|
render-multi-mixin)
|
|
|
|
(define as-literal
|
|
(let ([loc (xml:make-location 0 0 0)])
|
|
(lambda strings (xml:make-cdata loc loc (string-append* strings)))))
|
|
(define (ref-style path)
|
|
`(link ([rel "stylesheet"] [type "text/css"] [href ,path] [title "default"])))
|
|
(define (inlined-style . body)
|
|
`(style ([type "text/css"])
|
|
,(apply as-literal
|
|
`("\n"
|
|
,@(map (lambda (x) (if (string? x) x (format "~a" x))) body)
|
|
"\n"))))
|
|
(define (ref-script path)
|
|
`(script ([type "text/javascript"] [src ,path])))
|
|
(define (inlined-script . body)
|
|
`(script ([type "text/javascript"])
|
|
,(apply as-literal
|
|
`("\n"
|
|
,@(map (lambda (x) (if (string? x) x (format "~a" x))) body)
|
|
"\n"))))
|
|
|
|
(define-runtime-path scribble-css "scribble.css")
|
|
(define-runtime-path scribble-style-css "scribble-style.css")
|
|
(define-runtime-path scribble-prefix-html "scribble-prefix.html")
|
|
(define-runtime-path scribble-js "scribble-common.js")
|
|
;; utilities for render-one-part
|
|
(define-values (scribble-css-contents scribble-js-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 make-inline make-ref)
|
|
(let ([c #f])
|
|
(lambda (file path)
|
|
(cond [(bytes? file)
|
|
(make-inline (bytes->string/utf-8 file))]
|
|
[(not (eq? 'inline path))
|
|
(make-ref (or path (let-values ([(base name dir?)
|
|
(split-path file)])
|
|
(path->string name))))]
|
|
[(or (not file) (equal? file default-file))
|
|
(unless c
|
|
(set! c (make-inline (read-file default-file))))
|
|
c]
|
|
[else (make-inline (read-file file))]))))])
|
|
(values (file-getter scribble-css inlined-style ref-style)
|
|
(file-getter scribble-js inlined-script ref-script))))
|
|
|
|
(define (lookup-path path mapping)
|
|
(ormap (lambda (p)
|
|
(and (equal? (car p) path)
|
|
(cdr p)))
|
|
mapping))
|
|
|
|
(define current-subdirectory (make-parameter #f))
|
|
(define current-output-file (make-parameter #f))
|
|
(define current-top-part (make-parameter #f))
|
|
(define on-separate-page-ok (make-parameter #t))
|
|
(define collecting-sub (make-parameter 0))
|
|
(define collecting-whole-page (make-parameter #t))
|
|
(define current-no-links (make-parameter #f))
|
|
(define extra-breaking? (make-parameter #f))
|
|
(define current-version (make-parameter (version)))
|
|
(define current-part-files (make-parameter #f))
|
|
|
|
(define (toc-part? d)
|
|
(part-style? d 'toc))
|
|
|
|
;; HTML anchors should be case-insensitively unique. 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. (The idea is that the result is still readable, so the
|
|
;; link can be used as a rough indication of where you'll get to.)
|
|
(define (anchor-name v)
|
|
(define (encode-byte b)
|
|
(string-append (if (< b 16) "~0" "~") (number->string b 16)))
|
|
(define (encode-bytes str)
|
|
(string->bytes/utf-8 (encode-byte (bytes-ref str 0))))
|
|
(if (literal-anchor? v)
|
|
(literal-anchor-string v)
|
|
(let* ([v (string->bytes/utf-8 (format "~a" v))]
|
|
[v (regexp-replace* #rx#"[A-Z.]" v #".&")]
|
|
[v (regexp-replace* #rx#" " v #"._")]
|
|
[v (regexp-replace* #rx#"\"" v #".'")]
|
|
[v (regexp-replace* #rx#"[^-a-zA-Z0-9_!+*'()/.,]" v encode-bytes)])
|
|
(bytes->string/utf-8 v))))
|
|
|
|
(define-serializable-struct literal-anchor (string))
|
|
|
|
(define (color->string c)
|
|
(if (string? c)
|
|
c
|
|
(string-append*
|
|
"#"
|
|
(map (lambda (v)
|
|
(let ([s (number->string v 16)])
|
|
(if (< v 16) (string-append "0" s) s)))
|
|
c))))
|
|
|
|
(define (style->attribs style)
|
|
(let ([a (apply
|
|
append
|
|
(map (lambda (v)
|
|
(cond
|
|
[(attributes? v)
|
|
(map (lambda (v) (list (car v) (cdr v))) (attributes-assoc v))]
|
|
[(color-property? v)
|
|
`((style ,(format "color: ~a" (color->string (color-property-color v)))))]
|
|
[(background-color-property? v)
|
|
`((style ,(format "background-color: ~a" (color->string (background-color-property-color v)))))]
|
|
[(hover-property? v)
|
|
`((title ,(hover-property-text v)))]
|
|
[else null]))
|
|
(style-properties style)))])
|
|
(let ([name (style-name style)])
|
|
(if (string? name)
|
|
(cons `[class ,name]
|
|
a)
|
|
a))))
|
|
|
|
(define (style->tag style)
|
|
(for/or ([s (in-list (style-properties style))])
|
|
(and (alt-tag? s)
|
|
(string->symbol (alt-tag-name s)))))
|
|
|
|
(define (make-search-box top-path) ; appears on every page
|
|
(let ([sa string-append]
|
|
[emptylabel "...search manuals..."]
|
|
[dimcolor "#888"])
|
|
`(form ([class "searchform"])
|
|
(input
|
|
([class "searchbox"]
|
|
[style ,(sa "color: "dimcolor";")]
|
|
[type "text"]
|
|
[value ,emptylabel]
|
|
[title "Enter a search string to search the manuals"]
|
|
[onkeypress ,(format "return DoSearchKey(event, this, ~s, ~s);"
|
|
(version) top-path)]
|
|
[onfocus ,(sa "this.style.color=\"black\"; "
|
|
"this.style.textAlign=\"left\"; "
|
|
"if (this.value == \""emptylabel"\") this.value=\"\";")]
|
|
[onblur ,(sa "if (this.value.match(/^ *$/)) {"
|
|
" this.style.color=\""dimcolor"\";"
|
|
" this.style.textAlign=\"center\";"
|
|
" this.value=\""emptylabel"\"; }")])))))
|
|
(define search-box (make-search-box "../"))
|
|
(define top-search-box (make-search-box ""))
|
|
|
|
;; ----------------------------------------
|
|
;; main mixin
|
|
|
|
(define (render-mixin %)
|
|
(class %
|
|
(inherit render-block
|
|
render-part
|
|
collect-part
|
|
install-file
|
|
get-dest-directory
|
|
format-number
|
|
quiet-table-of-contents
|
|
extract-part-style-files
|
|
extract-version
|
|
extract-authors
|
|
extract-pretitle)
|
|
(inherit-field prefix-file style-file style-extra-files)
|
|
|
|
(init-field [alt-paths null]
|
|
;; up-path is either a link "up", or #t which uses
|
|
;; goes to start page (using cookies to get to the
|
|
;; user start page). If it's a path, then it's also
|
|
;; used for the "top" link on the page.
|
|
[up-path #f]
|
|
[script-path #f]
|
|
[script-file #f]
|
|
[search-box? #f])
|
|
|
|
(define/override (current-render-mode)
|
|
'(html))
|
|
|
|
(define/override (get-suffix) #".html")
|
|
|
|
(define/override (index-manual-newlines?)
|
|
#t)
|
|
|
|
(define/override (auto-extra-files? v) (html-defaults? v))
|
|
(define/override (auto-extra-files-paths v) (html-defaults-extra-files v))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(inherit path->root-relative
|
|
root-relative->path
|
|
root-relative?)
|
|
|
|
(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)
|
|
(if (root-relative? p)
|
|
(root-relative->path p)
|
|
(let ([p (if (or (not (pair? p))
|
|
(eq? (car p) 'doc))
|
|
(main-doc-relative->path p)
|
|
p)])
|
|
(if (path? p)
|
|
p
|
|
(main-collects-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 (fresh-tag-collect-context? d ci)
|
|
(current-part-whole-page? d))
|
|
(define/override (fresh-tag-resolve-context? d ri)
|
|
(part-whole-page? d ri))
|
|
(define/override (fresh-tag-render-context? d ri)
|
|
(part-whole-page? d ri))
|
|
|
|
(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)
|
|
(add-current-tag-prefix 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)))
|
|
(let ([tag (target-element-tag i)])
|
|
(if (and (pair? tag) (eq? 'part (car tag)))
|
|
(element-content i)
|
|
#f))
|
|
(page-target-element? i)
|
|
(if (redirect-target-element? i)
|
|
(make-literal-anchor
|
|
(redirect-target-element-alt-anchor i))
|
|
(add-current-tag-prefix 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 external-root-url #f)
|
|
(define/public (set-external-root-url p)
|
|
(set! external-root-url p))
|
|
|
|
(define (try-relative-to-external-root dest)
|
|
(cond
|
|
[(let ([rel (find-relative-path
|
|
(find-doc-dir)
|
|
(relative->path (dest-path dest)))])
|
|
(and (relative-path? rel)
|
|
rel))
|
|
=> (lambda (rel)
|
|
(cons
|
|
(url->string
|
|
(struct-copy
|
|
url
|
|
(combine-url/relative
|
|
(string->url external-root-url)
|
|
(string-join (map path-element->string
|
|
(explode-path rel))
|
|
"/"))))
|
|
(and (not (dest-page? dest))
|
|
(anchor-name (dest-anchor dest)))))]
|
|
[else #f]))
|
|
|
|
(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-root-url
|
|
(try-relative-to-external-root dest))
|
|
=> (lambda (p)
|
|
(values (car p) (cdr p)))]
|
|
[(and ext? external-tag-path)
|
|
(values (string->url 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) ;!!! need to use this
|
|
(part-style? p 'reveal))
|
|
|
|
(define/public (toc-wrap table)
|
|
null)
|
|
|
|
(define/private (dest->url dest)
|
|
(format "~a~a~a"
|
|
(let ([p (relative->path (dest-path dest))])
|
|
(if (equal? p (current-output-file))
|
|
""
|
|
(from-root p (get-dest-directory))))
|
|
(if (dest-page? dest) "" "#")
|
|
(if (dest-page? dest)
|
|
""
|
|
(anchor-name (dest-anchor dest)))))
|
|
|
|
(define/public (render-toc-view d ri)
|
|
(define has-sub-parts?
|
|
(pair? (part-parts d)))
|
|
(define sub-parts-on-other-page?
|
|
(and has-sub-parts?
|
|
(part-whole-page? (car (part-parts d)) ri)))
|
|
(define toc-chain
|
|
(let loop ([d d] [r (if has-sub-parts? (list d) '())])
|
|
(cond [(collected-info-parent (part-collected-info d ri))
|
|
=> (lambda (p) (loop p (cons p r)))]
|
|
[(pair? r) r]
|
|
;; we have no toc, so use just the current part
|
|
[else (list d)])))
|
|
(define top (car toc-chain))
|
|
(define (toc-item->title+num t show-mine?)
|
|
(values
|
|
`((a ([href ,(dest->url (resolve-get t ri (car (part-tags t))))]
|
|
[class ,(if (or (eq? t d) (and show-mine? (memq t toc-chain)))
|
|
"tocviewselflink"
|
|
"tocviewlink")]
|
|
[pltdoc "x"])
|
|
,@(render-content (or (part-title-content t) '("???")) d ri)))
|
|
(format-number (collected-info-number (part-collected-info t ri))
|
|
'(nbsp))))
|
|
(define (toc-item->block t i)
|
|
(define-values (title num) (toc-item->title+num t #f))
|
|
(define children ; note: might be empty
|
|
(filter (lambda (p) (not (part-style? p 'toc-hidden)))
|
|
(part-parts t)))
|
|
(define id (format "tocview_~a" i))
|
|
(define last? (eq? t (last toc-chain)))
|
|
(define expand? (or (and last?
|
|
(or (not has-sub-parts?)
|
|
sub-parts-on-other-page?))
|
|
(and has-sub-parts?
|
|
(not sub-parts-on-other-page?)
|
|
;; next-to-last?
|
|
(let loop ([l toc-chain])
|
|
(cond
|
|
[(null? l) #f]
|
|
[(eq? t (car l))
|
|
(and (pair? (cdr l)) (null? (cddr l)))]
|
|
[else (loop (cdr l))])))))
|
|
(define top? (eq? t top))
|
|
(define header
|
|
`(table ([cellspacing "0"] [cellpadding "0"])
|
|
(tr ()
|
|
(td ([style "width: 1em;"])
|
|
,(if (null? children)
|
|
'bull
|
|
`(a ([href "javascript:void(0);"]
|
|
[title "Expand/Collapse"]
|
|
[class "tocviewtoggle"]
|
|
[onclick ,(format "TocviewToggle(this,\"~a\");" id)])
|
|
,(if expand? 9660 9658))))
|
|
(td () ,@num)
|
|
(td () ,@title))))
|
|
`(div ([class "tocviewlist"]
|
|
,@(if top? `([style "margin-bottom: 1em;"]) '()))
|
|
,(if top? `(div ([class "tocviewtitle"]) ,header) header)
|
|
,(if (null? children)
|
|
""
|
|
`(div ([class ,(cond
|
|
[(and top? last?) "tocviewsublistonly"]
|
|
[top? "tocviewsublisttop"]
|
|
[last? "tocviewsublistbottom"]
|
|
[else "tocviewsublist"])]
|
|
[style ,(format "display: ~a;" (if expand? 'block 'none))]
|
|
[id ,id])
|
|
(table ([cellspacing "0"] [cellpadding "0"])
|
|
,@(for/list ([c children])
|
|
(let-values ([(t n) (toc-item->title+num c #t)])
|
|
`(tr () (td ([align "right"]) ,@n) (td () ,@t)))))))))
|
|
(define (toc-content)
|
|
;; no links -- the code constructs links where needed
|
|
(parameterize ([current-no-links #t]
|
|
[extra-breaking? #t])
|
|
(for/list ([t toc-chain] [i (in-naturals)])
|
|
(toc-item->block t i))))
|
|
`((div ([class "tocset"])
|
|
,@(if (part-style? d 'no-toc)
|
|
null
|
|
;; toc-wrap determines if we get the toc or just the title !!!
|
|
`((div ([class "tocview"]) ,@(toc-content))))
|
|
,@(render-onthispage-contents
|
|
d ri top (if (part-style? d 'no-toc) "tocview" "tocsub")
|
|
sub-parts-on-other-page?)
|
|
,@(parameterize ([extra-breaking? #t])
|
|
(append-map (lambda (e)
|
|
(let loop ([e e])
|
|
(cond
|
|
[(and (table? e)
|
|
(memq 'aux (style-properties (table-style e)))
|
|
(pair? (table-blockss e)))
|
|
(render-table e d ri #f)]
|
|
[(delayed-block? e)
|
|
(loop (delayed-block-blocks e ri))]
|
|
[(traverse-block? e)
|
|
(loop (traverse-block-block e ri))]
|
|
[(compound-paragraph? e)
|
|
(append-map loop (compound-paragraph-blocks e))]
|
|
[else null])))
|
|
(part-blocks d))))))
|
|
|
|
(define/public (get-onthispage-label)
|
|
null)
|
|
|
|
(define/public (nearly-top? d ri top)
|
|
#f)
|
|
|
|
(define/private (render-onthispage-contents d ri top box-class sections-in-toc?)
|
|
(if (ormap (lambda (p) (or (part-whole-page? p ri)
|
|
(part-style? p 'toc-hidden)))
|
|
(part-parts d))
|
|
null
|
|
(let ([nearly-top? (lambda (d)
|
|
;; If ToC would be collapsed, then
|
|
;; no section is nearly the top
|
|
(if (not sections-in-toc?)
|
|
#f
|
|
(nearly-top? d ri top)))])
|
|
(define (flow-targets flow)
|
|
(append-map block-targets flow))
|
|
(define (block-targets e)
|
|
(cond [(table? e) (table-targets e)]
|
|
[(paragraph? e) (para-targets e)]
|
|
[(itemization? e)
|
|
(append-map flow-targets (itemization-blockss e))]
|
|
[(nested-flow? e)
|
|
(append-map block-targets (nested-flow-blocks e))]
|
|
[(compound-paragraph? e)
|
|
(append-map block-targets (compound-paragraph-blocks e))]
|
|
[(delayed-block? e) null]
|
|
[(traverse-block? e) (block-targets (traverse-block-block e ri))]))
|
|
(define (para-targets para)
|
|
(let loop ([a (paragraph-content para)])
|
|
(cond
|
|
[(list? a) (append-map loop a)]
|
|
[(toc-target-element? a) (list a)]
|
|
[(toc-element? a) (list a)]
|
|
[(element? a) (loop (element-content a))]
|
|
[(delayed-element? a) (loop (delayed-element-content a ri))]
|
|
[(traverse-element? a) (loop (traverse-element-content a ri))]
|
|
[(part-relative-element? a) (loop (part-relative-element-content a ri))]
|
|
[else null])))
|
|
(define (table-targets table)
|
|
(append-map
|
|
(lambda (blocks)
|
|
(append-map (lambda (f) (if (eq? f 'cont) null (block-targets f)))
|
|
blocks))
|
|
(table-blockss table)))
|
|
(define ps
|
|
((if (nearly-top? d) values cdr)
|
|
(let flatten ([d d][prefixes null][top? #t])
|
|
(let ([prefixes (if (and (not top?) (part-tag-prefix d))
|
|
(cons (part-tag-prefix d) prefixes)
|
|
prefixes)])
|
|
(append*
|
|
;; don't include the section if it's in the TOC
|
|
(if (nearly-top? d) null (list (cons d prefixes)))
|
|
;; get internal targets:
|
|
(map (lambda (v) (cons v prefixes)) (append-map block-targets (part-blocks d)))
|
|
(map (lambda (p) (if (or (part-whole-page? p ri)
|
|
(part-style? p 'toc-hidden))
|
|
null
|
|
(flatten p prefixes #f)))
|
|
(part-parts d)))))))
|
|
(define any-parts? (ormap (compose part? car) ps))
|
|
(if (null? ps)
|
|
null
|
|
`((div ([class ,box-class])
|
|
,@(get-onthispage-label)
|
|
(table ([class "tocsublist"] [cellspacing "0"])
|
|
,@(map (lambda (p)
|
|
(let ([p (car p)]
|
|
[prefixes (cdr p)]
|
|
[add-tag-prefixes
|
|
(lambda (t prefixes)
|
|
(if (null? prefixes)
|
|
t
|
|
(cons (car t) (append prefixes (cdr t)))))])
|
|
`(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
|
|
,(format
|
|
"#~a"
|
|
(anchor-name
|
|
(add-tag-prefixes
|
|
(tag-key (if (part? p)
|
|
(car (part-tags p))
|
|
(target-element-tag p))
|
|
ri)
|
|
prefixes)))]
|
|
[class
|
|
,(cond
|
|
[(part? p) "tocsubseclink"]
|
|
[any-parts? "tocsubnonseclink"]
|
|
[else "tocsublink"])]
|
|
[pltdoc "x"])
|
|
,@(render-content
|
|
(if (part? p)
|
|
(or (part-title-content p)
|
|
"???")
|
|
(element-content p))
|
|
d ri)))))))))
|
|
ps))))))))
|
|
|
|
(define/public (extract-part-body-id d ri)
|
|
(or (ormap (lambda (v)
|
|
(and (body-id? v)
|
|
(body-id-value v)))
|
|
(style-properties (part-style d)))
|
|
(let ([p (part-parent d ri)])
|
|
(and p (extract-part-body-id p ri)))))
|
|
|
|
(define/public (render-one-part d ri fn number)
|
|
(parameterize ([current-output-file fn])
|
|
(let* ([defaults (ormap (lambda (v) (and (html-defaults? v) v))
|
|
(style-properties (part-style d)))]
|
|
[prefix-file (or prefix-file
|
|
(and defaults
|
|
(let ([v (html-defaults-prefix-path defaults)])
|
|
(if (bytes? v)
|
|
v
|
|
(main-collects-relative->path v))))
|
|
scribble-prefix-html)]
|
|
[style-file (or style-file
|
|
(and defaults
|
|
(let ([v (html-defaults-style-path defaults)])
|
|
(if (bytes? v)
|
|
v
|
|
(main-collects-relative->path v))))
|
|
scribble-style-css)]
|
|
[script-file (or script-file scribble-js)]
|
|
[title (cond [(part-title-content d)
|
|
=> (lambda (c)
|
|
`(title ,@(format-number number '(nbsp))
|
|
,(content->string c this d ri)))]
|
|
[else `(title)])])
|
|
(unless (bytes? style-file)
|
|
(unless (lookup-path style-file alt-paths)
|
|
(install-file style-file)))
|
|
(unless (lookup-path scribble-css alt-paths)
|
|
(install-file scribble-css))
|
|
(unless (lookup-path script-file alt-paths)
|
|
(install-file script-file))
|
|
(if (bytes? prefix-file)
|
|
(display prefix-file)
|
|
(call-with-input-file*
|
|
prefix-file
|
|
(lambda (in)
|
|
(copy-port in (current-output-port)))))
|
|
(parameterize ([xml:empty-tag-shorthand xml:html-empty-tags])
|
|
(xml:write-xml/content
|
|
(xml:xexpr->xml
|
|
`(html ()
|
|
(head ()
|
|
(meta ([http-equiv "content-type"]
|
|
[content "text-html; charset=utf-8"]))
|
|
,title
|
|
,(scribble-css-contents scribble-css (lookup-path scribble-css alt-paths))
|
|
,@(map (lambda (style-file)
|
|
(if (bytes? style-file)
|
|
(scribble-css-contents style-file #f)
|
|
(let ([p (lookup-path style-file alt-paths)])
|
|
(unless p (install-file style-file))
|
|
(scribble-css-contents style-file p))))
|
|
(append (extract-part-style-files
|
|
d
|
|
ri
|
|
'css
|
|
(lambda (p) (part-whole-page? p ri))
|
|
css-addition?
|
|
css-addition-path)
|
|
(list style-file)
|
|
style-extra-files))
|
|
,(scribble-js-contents script-file (lookup-path script-file alt-paths)))
|
|
(body ([id ,(or (extract-part-body-id d ri)
|
|
"scribble-racket-lang-org")])
|
|
,@(render-toc-view d ri)
|
|
(div ([class "maincolumn"])
|
|
(div ([class "main"])
|
|
,@(parameterize ([current-version (extract-version d)])
|
|
(render-version d ri))
|
|
,@(navigation d ri #t)
|
|
,@(render-part d ri)
|
|
,@(navigation d ri #f)))
|
|
(div ([id "contextindicator"]) nbsp)))))))))
|
|
|
|
(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 top-content "top")
|
|
(define contents-content "contents")
|
|
(define index-content "index")
|
|
(define prev-content '(larr " prev"))
|
|
(define up-content "up")
|
|
(define next-content '("next " rarr))
|
|
(define sep-element '(nbsp nbsp))
|
|
|
|
(define/public (derive-filename d ci ri) "bad.html")
|
|
|
|
(define/public (include-navigation?) search-box?)
|
|
|
|
(define/private (navigation d ri top?)
|
|
(define parent (part-parent d ri))
|
|
(define-values (prev0 next0) (find-siblings d ri))
|
|
(define prev
|
|
(if prev0
|
|
(let loop ([p prev0])
|
|
(if (and (toc-part? p) (pair? (part-parts p)))
|
|
(loop (last (part-parts p)))
|
|
p))
|
|
(and parent (toc-part? parent) parent)))
|
|
(define next
|
|
(cond [(and (toc-part? d) (pair? (part-parts d))) (car (part-parts d))]
|
|
[(not next0)
|
|
(let loop ([p parent])
|
|
(and p (toc-part? p)
|
|
(let-values ([(prev next) (find-siblings p ri)])
|
|
(or next (loop (part-parent p ri))))))]
|
|
[else next0]))
|
|
(define 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 (last subs)])
|
|
(and (eq? (style-name (part-style d)) 'index)
|
|
d))))))))
|
|
(define (render . content)
|
|
(render-content (filter values content) d ri))
|
|
(define (titled-url label x #:title-from [tfrom #f] . more)
|
|
(define-values (url title)
|
|
(cond [(part? x)
|
|
(values
|
|
(dest->url (resolve-get x ri (car (part-tags x))))
|
|
(string-append
|
|
"\""
|
|
(content->string
|
|
(append (format-number (collected-info-number
|
|
(part-collected-info x ri))
|
|
'(" "))
|
|
(part-title-content x)))
|
|
"\""))]
|
|
[(equal? x "index.html") (values x "the manual top")]
|
|
[(equal? x "../index.html") (values x "the documentation top")]
|
|
[(string? x) (values x #f)]
|
|
[(path? x) (values (url->string (path->url x)) #f)]
|
|
[else (error 'navigation "internal error ~e" x)]))
|
|
(define title*
|
|
(if (and tfrom (part? tfrom))
|
|
(string-append
|
|
"\"" (content->string (part-title-content tfrom)) "\"")
|
|
title))
|
|
(make-style
|
|
#f
|
|
(list
|
|
(make-target-url url)
|
|
(make-attributes
|
|
`([title . ,(if title* (string-append label " to " title*) label)]
|
|
[pltdoc . "x"]
|
|
,@more)))))
|
|
(define top-link
|
|
(titled-url
|
|
"up" (if (path? up-path)
|
|
(url->string (path->url up-path))
|
|
"../index.html")
|
|
`[onclick . ,(format "return GotoPLTRoot(\"~a\");" (version))]))
|
|
(define navleft
|
|
`(span ([class "navleft"])
|
|
,@(if search-box?
|
|
(list (if up-path search-box top-search-box))
|
|
null)
|
|
,@(render
|
|
sep-element
|
|
(and up-path (make-element top-link top-content))
|
|
;; sep-element
|
|
;; (make-element
|
|
;; (if parent (make-target-url "index.html" #f) "nonavigation")
|
|
;; contents-content)
|
|
;; sep-element
|
|
;; (if (or (not index) (eq? d index))
|
|
;; (make-element "nonavigation" index-content)
|
|
;; (make-link-element #f index-content (car (part-tags index))))
|
|
)))
|
|
(define navright
|
|
(if (not (or parent up-path next))
|
|
""
|
|
`(span ([class "navright"])
|
|
,@(render
|
|
(make-element
|
|
(cond [(not parent) "nonavigation"]
|
|
[prev (titled-url "backward" prev)]
|
|
[else (titled-url "backward" "index.html"
|
|
#:title-from
|
|
(and (part? parent) parent))])
|
|
prev-content)
|
|
sep-element
|
|
(make-element
|
|
(cond
|
|
[(and (part? parent) (toc-part? parent)
|
|
(part-parent parent ri))
|
|
(titled-url "up" parent)]
|
|
[parent (titled-url "up" "index.html" #:title-from parent)]
|
|
;; up-path = #t => go up to the start page, using
|
|
;; cookies to get to the user's version of it (see
|
|
;; scribblings/main/private/utils for the code that
|
|
;; creates these cookies.)
|
|
[(eq? #t up-path) top-link]
|
|
[up-path (titled-url "up" up-path)]
|
|
[else "nonavigation"])
|
|
up-content)
|
|
sep-element
|
|
(make-element
|
|
(if next (titled-url "forward" next) "nonavigation")
|
|
next-content)))))
|
|
(define navbar
|
|
`(div ([class ,(if top? "navsettop" "navsetbottom")])
|
|
,navleft ,navright nbsp)) ; need nbsp to make the navset bg visible
|
|
(if (include-navigation?)
|
|
(list navbar)
|
|
null))
|
|
|
|
(define/override (render-one d ri fn)
|
|
(render-one-part d ri fn null))
|
|
|
|
(define/public (render-version d ri)
|
|
(let ([v (current-version)])
|
|
(if (equal? v "")
|
|
;; don't show empty version:
|
|
null
|
|
;; show version:
|
|
`((div ([class "versionbox"])
|
|
,@(render-content
|
|
(list (make-element (if (include-navigation?)
|
|
"version"
|
|
"versionNoNav")
|
|
(list "Version: " v)))
|
|
d
|
|
ri))))))
|
|
|
|
(define/override (render-part-content d ri)
|
|
(let ([number (collected-info-number (part-collected-info d ri))])
|
|
`(,@(let ([pres (extract-pretitle d)])
|
|
(append-map (lambda (pre)
|
|
(do-render-paragraph pre d ri #f #t))
|
|
pres))
|
|
,@(cond
|
|
[(and (not (part-title-content d)) (null? number)) null]
|
|
[(part-style? d 'hidden)
|
|
(map (lambda (t)
|
|
`(a ((name ,(format "~a" (anchor-name
|
|
(add-current-tag-prefix
|
|
(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
|
|
(add-current-tag-prefix
|
|
(tag-key t ri))))])))
|
|
(part-tags d))
|
|
,@(if (part-title-content d)
|
|
(render-content (part-title-content d) d ri)
|
|
null)))])
|
|
,@(let ([auths (extract-authors d)])
|
|
(if (null? auths)
|
|
null
|
|
`((div ([class "SAuthorListBox"])
|
|
(span ([class "SAuthorList"])
|
|
,@(apply
|
|
append
|
|
(for/list ([auth (in-list auths)]
|
|
[pos (in-naturals)])
|
|
(let ([v (do-render-paragraph auth d ri #f #t)])
|
|
(if (zero? pos)
|
|
v
|
|
(cons '(span ([class "SAuthorSep"]) (br)) v))))))))))
|
|
,@(render-flow* (part-blocks 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 starting-item? special-last?)
|
|
;; Wrap each table with <p>, except for a trailing table
|
|
;; when `special-last?' is #t
|
|
(let loop ([f p] [starting-item? starting-item?])
|
|
(cond
|
|
[(null? f) null]
|
|
[(and (table? (car f))
|
|
(or (not special-last?) (not (null? (cdr f)))))
|
|
(cons `(p ,@(render-block (car f) part ri starting-item?))
|
|
(loop (cdr f) #f))]
|
|
[else (append (render-block (car f) part ri starting-item?)
|
|
(loop (cdr f) #f))])))
|
|
|
|
(define/override (render-flow p part ri starting-item?)
|
|
(render-flow* p part ri starting-item? #t))
|
|
|
|
(define/private (do-render-paragraph p part ri flatten-unstyled? show-pre?)
|
|
(let* ([contents (super render-paragraph p part ri)]
|
|
[style (paragraph-style p)]
|
|
[attrs (style->attribs style)])
|
|
(if (and (not show-pre?)
|
|
(or (eq? (style-name style) 'author)
|
|
(eq? (style-name style) 'pretitle)))
|
|
null
|
|
(if (and flatten-unstyled?
|
|
(not (style-name style))
|
|
(null? attrs))
|
|
contents
|
|
`((,(or (style->tag style)
|
|
(if (memq 'div (style-properties style))
|
|
'div
|
|
'p))
|
|
[,@attrs
|
|
,@(case (style-name style)
|
|
[(author) '([class "author"])]
|
|
[(pretitle) '([class "SPretitle"])]
|
|
[(wraps) null]
|
|
[else null])]
|
|
,@contents))))))
|
|
|
|
(define/override (render-paragraph p part ri)
|
|
(do-render-paragraph p part ri #f #f))
|
|
|
|
(define/override (render-intrapara-block p part ri first? last? starting-item?)
|
|
`((div ([class "SIntrapara"])
|
|
,@(cond
|
|
[(paragraph? p) (do-render-paragraph p part ri #t #f)]
|
|
[else (render-block p part ri starting-item?)]))))
|
|
|
|
(define/private (content-style e)
|
|
(cond
|
|
[(element? e) (element-style e)]
|
|
[(multiarg-element? e) (multiarg-element-style e)]
|
|
[else #f]))
|
|
|
|
(define/private (content-attribs e)
|
|
(let ([s (content-style e)])
|
|
(if (style? s)
|
|
(element-style->attribs (style-name s) s)
|
|
(element-style->attribs s #f))))
|
|
|
|
(define/override (render-content e part ri)
|
|
(define (attribs) (content-attribs e))
|
|
(cond
|
|
[(string? e) (super render-content e part ri)] ; short-cut for common case
|
|
[(list? e) (super render-content e part ri)] ; also a short-cut
|
|
[(and (convertible? e)
|
|
(convert e 'png-bytes))
|
|
=> (lambda (bstr)
|
|
(let ([w (integer-bytes->integer (subbytes bstr 16 20) #f #t)]
|
|
[h (integer-bytes->integer (subbytes bstr 20 24) #f #t)])
|
|
`((img ([src ,(install-file "pict.png" bstr)]
|
|
[alt "image"]
|
|
[width ,(number->string w)]
|
|
[height ,(number->string h)])))))]
|
|
[(image-element? e)
|
|
(let* ([src (main-collects-relative->path (image-element-path e))]
|
|
[suffixes (image-element-suffixes e)]
|
|
[scale (image-element-scale e)]
|
|
[to-num
|
|
(lambda (s)
|
|
(number->string
|
|
(inexact->exact
|
|
(floor (* scale (integer-bytes->integer s #f #t))))))]
|
|
[src (select-suffix src suffixes '(".png" ".gif" ".svg"))]
|
|
[svg? (regexp-match? #rx#"[.]svg$" (if (path? src) (path->bytes src) src))]
|
|
[sz (cond
|
|
[svg?
|
|
(call-with-input-file*
|
|
src
|
|
(lambda (in)
|
|
(with-handlers ([exn:fail? (lambda (exn)
|
|
(log-warning
|
|
(format "warning: error while reading SVG file for size: ~a"
|
|
(if (exn? exn)
|
|
(exn-message exn)
|
|
(format "~e" exn))))
|
|
null)])
|
|
(let* ([d (xml:read-xml in)]
|
|
[attribs (xml:element-attributes
|
|
(xml:document-element d))]
|
|
[check-name (lambda (n)
|
|
(lambda (a)
|
|
(and (eq? n (xml:attribute-name a))
|
|
(xml:attribute-value a))))]
|
|
[w (ormap (check-name 'width) attribs)]
|
|
[h (ormap (check-name 'height) attribs)])
|
|
(if (and w h)
|
|
`([width ,w][height ,h])
|
|
null)))))]
|
|
[(= 1.0 scale) null]
|
|
[else
|
|
;; Try to extract file size:
|
|
(call-with-input-file*
|
|
src
|
|
(lambda (in)
|
|
(cond
|
|
[(regexp-try-match #px#"^\211PNG.{12}" in)
|
|
`([width ,(to-num (read-bytes 4 in))]
|
|
[height ,(to-num (read-bytes 4 in))])]
|
|
[else
|
|
null])))])])
|
|
(let ([srcref (let ([p (install-file src)])
|
|
(if (path? p)
|
|
(url->string (path->url (path->complete-path p)))
|
|
p))])
|
|
`((,(if svg? 'object 'img)
|
|
([,(if svg? 'data 'src) ,srcref]
|
|
[alt ,(content->string (element-content e))]
|
|
,@(if svg?
|
|
`([type "image/svg+xml"])
|
|
null)
|
|
,@sz
|
|
,@(attribs))
|
|
,@(if svg?
|
|
`((param ([name "src"] [value ,srcref])))
|
|
null)))))]
|
|
[(and (or (element? e) (multiarg-element? e))
|
|
(ormap (lambda (v) (and (script-property? v) v))
|
|
(let ([s (if (element? e)
|
|
(element-style e)
|
|
(multiarg-element-style e))])
|
|
(if (style? s) (style-properties s) null))))
|
|
=>
|
|
(lambda (v)
|
|
(let* ([t `[type ,(script-property-type v)]]
|
|
[s (script-property-script v)]
|
|
[s (if (list? s)
|
|
`(script (,t ,@(attribs)) ,(apply as-literal `("\n" ,@s "\n")))
|
|
`(script (,t ,@(attribs) [src ,s])))])
|
|
(list s
|
|
`(noscript ,@(render-plain-content e part ri)))))]
|
|
[(target-element? e)
|
|
`((a ([name ,(format "~a" (anchor-name (add-current-tag-prefix
|
|
(tag-key (target-element-tag e)
|
|
ri))))]
|
|
,@(attribs)))
|
|
,@(render-content (element-content 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
|
|
,(cond
|
|
[(and ext? external-root-url
|
|
(let ([rel (find-relative-path
|
|
(find-doc-dir)
|
|
(relative->path (dest-path dest)))])
|
|
(and (relative-path? rel)
|
|
rel)))
|
|
=> (lambda (rel)
|
|
(url->string
|
|
(struct-copy
|
|
url
|
|
(combine-url/relative
|
|
(string->url external-root-url)
|
|
(string-join (map path-element->string
|
|
(explode-path rel))
|
|
"/"))
|
|
[fragment
|
|
(and (not (dest-page? dest))
|
|
(anchor-name (dest-anchor dest)))])))]
|
|
[(and ext? external-tag-path)
|
|
;; Redirected to search:
|
|
(url->string
|
|
(let ([u (string->url external-tag-path)])
|
|
(struct-copy
|
|
url
|
|
u
|
|
[query
|
|
(cons (cons 'tag
|
|
(bytes->string/utf-8
|
|
(base64-encode
|
|
(string->bytes/utf-8
|
|
(format "~s" (serialize
|
|
(link-element-tag e)))))))
|
|
(url-query u))])))]
|
|
[else
|
|
;; Normal link:
|
|
(dest->url dest)]))
|
|
,@(attribs)
|
|
[pltdoc "x"]]
|
|
,@(if (empty-content? (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 (empty-content? (element-content e))
|
|
`(,(format "~s" (tag-key (link-element-tag e) ri)))
|
|
(render-plain-content e part ri))))))))]
|
|
[else
|
|
(when (render-element? e)
|
|
((render-element-render e) this part ri))
|
|
(render-plain-content e part ri)]))
|
|
|
|
(define/private (render-plain-content e part ri)
|
|
(define (attribs) (content-attribs e))
|
|
(let* ([properties (let ([s (content-style e)])
|
|
(if (style? s)
|
|
(style-properties s)
|
|
null))]
|
|
[name (let ([s (content-style e)])
|
|
(if (style? s)
|
|
(style-name s)
|
|
s))]
|
|
[alt-tag
|
|
(let ([s (content-style e)])
|
|
(and (style? s)
|
|
(style->tag s)))]
|
|
[link? (and (ormap target-url? properties)
|
|
(not (current-no-links)))]
|
|
[anchor? (ormap url-anchor? properties)]
|
|
[attribs
|
|
(append
|
|
(if (null? properties)
|
|
null
|
|
(append-map (lambda (v)
|
|
(cond
|
|
[(target-url? v)
|
|
(if (current-no-links)
|
|
null
|
|
`([href ,(let ([addr (target-url-addr v)])
|
|
(if (path? addr)
|
|
(from-root addr (get-dest-directory))
|
|
addr))]))]
|
|
[else null]))
|
|
properties))
|
|
(attribs))]
|
|
[newline? (eq? name 'newline)])
|
|
(let-values ([(content) (cond
|
|
[link?
|
|
(parameterize ([current-no-links #t])
|
|
(super render-content e part ri))]
|
|
[newline? null]
|
|
[(eq? 'hspace name)
|
|
(let ([str (content->string e)])
|
|
(map (lambda (c) 'nbsp) (string->list str)))]
|
|
[else
|
|
(super render-content e part ri)])])
|
|
(if (and (null? attribs)
|
|
(not link?)
|
|
(not anchor?)
|
|
(not newline?)
|
|
(not alt-tag))
|
|
content
|
|
`(,@(if anchor?
|
|
(append-map (lambda (v)
|
|
(if (url-anchor? v)
|
|
`((a ([name ,(url-anchor-name v)])))
|
|
null))
|
|
properties)
|
|
null)
|
|
(,(cond
|
|
[alt-tag alt-tag]
|
|
[link? 'a]
|
|
[newline? 'br]
|
|
[else 'span])
|
|
,attribs
|
|
,@content))))))
|
|
|
|
(define/private (element-style->attribs name style)
|
|
(append
|
|
(cond
|
|
[(symbol? name)
|
|
(case name
|
|
[(italic) '([style "font-style: italic"])]
|
|
[(bold) '([style "font-weight: bold"])]
|
|
[(tt) '([class "stt"])]
|
|
[(url) '([class "url"])]
|
|
[(no-break) '([class "nobreak"])]
|
|
[(sf) '([style "font-family: sans-serif; font-size: 80%; font-weight: bold"])]
|
|
[(superscript) '([style "vertical-align: super; font-size: 80%"])]
|
|
[(subscript) '([style "vertical-align: sub; font-size: 80%"])]
|
|
[(smaller) '([class "Smaller"])]
|
|
[(larger) '([class "Larger"])]
|
|
[(hspace) '([class "hspace"])]
|
|
[(newline) '()]
|
|
[else (error 'html-render "unrecognized style symbol: ~e" name)])]
|
|
[(string? name) (if style null `([class ,name]))]
|
|
[else null])
|
|
(if style
|
|
(style->attribs style)
|
|
null)))
|
|
|
|
(define/override (render-table t part ri starting-item?)
|
|
(define (make-row flows column-styles)
|
|
`(tr
|
|
,@(let loop ([ds flows]
|
|
[column-styles column-styles]
|
|
[first? #t])
|
|
(cond
|
|
[(null? ds) null]
|
|
[(eq? (car ds) 'cont)
|
|
(loop (cdr ds) (cdr column-styles) first?)]
|
|
[else
|
|
(let ([d (car ds)] [column-style (car column-styles)])
|
|
(cons
|
|
`(td (,@(cond
|
|
[(not column-style) null]
|
|
[(memq 'right (style-properties column-style)) '([align "right"])]
|
|
[(memq 'left (style-properties column-style)) '([align "left"])]
|
|
[(memq 'center (style-properties column-style)) '([align "center"])]
|
|
[else null])
|
|
,@(cond
|
|
[(not column-style) null]
|
|
[(memq 'top (style-properties column-style)) '([valign "top"])]
|
|
[(memq 'baseline (style-properties column-style)) '([valign "baseline"])]
|
|
[(memq 'vcenter (style-properties column-style)) '([valign "center"])]
|
|
[(memq 'bottom (style-properties column-style)) '([valign "bottom"])]
|
|
[else null])
|
|
,@(if (and column-style
|
|
(string? (style-name column-style)))
|
|
`([class ,(style-name column-style)])
|
|
null)
|
|
,@(if (and column-style
|
|
(pair? (style-properties column-style)))
|
|
(style->attribs (make-style
|
|
#f
|
|
(filter attributes?
|
|
(style-properties column-style))))
|
|
null)
|
|
,@(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))
|
|
,@(if (and (paragraph? d)
|
|
(memq 'omitable (style-properties (paragraph-style d))))
|
|
(render-content (paragraph-content d) part ri)
|
|
(render-block d part ri #f)))
|
|
(loop (cdr ds) (cdr column-styles) #f)))]))))
|
|
`((table ([cellspacing "0"]
|
|
,@(if starting-item?
|
|
'([style "display: inline-table; vertical-align: text-top;"])
|
|
null)
|
|
,@(case (style-name (table-style t))
|
|
[(boxed) '([class "boxed"])]
|
|
[(centered) '([align "center"])]
|
|
[else '()])
|
|
,@(style->attribs (table-style t)))
|
|
,@(if (null? (table-blockss t))
|
|
`((tr (td)))
|
|
(map make-row
|
|
(table-blockss t)
|
|
(extract-table-cell-styles t))))))
|
|
|
|
(define/override (render-nested-flow t part ri)
|
|
`((blockquote [,@(style->attribs (nested-flow-style t))
|
|
,@(cond
|
|
[(eq? 'code-inset (style-name (nested-flow-style t)))
|
|
`([class "SCodeFlow"])]
|
|
[(eq? 'vertical-inset (style-name (nested-flow-style t)))
|
|
`([class "SVInsetFlow"])]
|
|
[(and (not (string? (style-name (nested-flow-style t))))
|
|
(not (eq? 'inset (style-name (nested-flow-style t)))))
|
|
`([class "SubFlow"])]
|
|
[else null])]
|
|
,@(append-map (lambda (i) (render-block i part ri #f))
|
|
(nested-flow-blocks t)))))
|
|
|
|
(define/override (render-compound-paragraph t part ri starting-item?)
|
|
(let ([style (compound-paragraph-style t)])
|
|
`((,(or (style->tag style) 'p)
|
|
,(style->attribs style)
|
|
,@(super render-compound-paragraph t part ri starting-item?)))))
|
|
|
|
(define/override (render-itemization t part ri)
|
|
(let ([style-str (or (and (string? (style-name (itemization-style t)))
|
|
(style-name (itemization-style t)))
|
|
(and (eq? 'compact (itemization-style t))
|
|
"compact"))])
|
|
`((,(if (eq? 'ordered (style-name (itemization-style t)))
|
|
'ol
|
|
'ul)
|
|
,(style->attribs (itemization-style t))
|
|
,@(map (lambda (flow) `(li ,(if style-str
|
|
`([class ,(string-append style-str "Item")])
|
|
`())
|
|
,@(render-flow flow part ri #t)))
|
|
(itemization-blockss 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)))]
|
|
[(symbol? i)
|
|
(case i
|
|
[(mdash) '(8212 (wbr))] ;; <wbr> encourages breaking after rather than before
|
|
;; use "single left/right-pointing angle quotation mark"
|
|
;; -- it's not a correct choice, but works best for now
|
|
;; (see the "Fonts with proper angle brackets"
|
|
;; discussion on the mailing list from June 2008)
|
|
[(lang) '(8249)]
|
|
[(rang) '(8250)]
|
|
[else (list i)])]
|
|
[else
|
|
(log-error (format "Unreocgnized element in content: ~e" i))
|
|
(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
|
|
install-extra-files
|
|
report-output?)
|
|
|
|
(define/override (get-suffix) #"")
|
|
|
|
(define/override (get-dest-directory [create? #f])
|
|
(or (and (current-subdirectory)
|
|
(let ([d (build-path (or (super get-dest-directory)
|
|
(current-directory))
|
|
(current-subdirectory))])
|
|
(when (and create? (not (directory-exists? d)))
|
|
(make-directory* d))
|
|
d))
|
|
(super get-dest-directory create?)))
|
|
|
|
(define/private (append-part-prefixes d ci ri)
|
|
(let ([parents (drop-right
|
|
(if ci
|
|
(cons d (collect-info-parents ci))
|
|
(let loop ([d d])
|
|
(if d
|
|
(cons d
|
|
(loop (collected-info-parent (part-collected-info d ri))))
|
|
null)))
|
|
1)])
|
|
(apply
|
|
string-append
|
|
(for/list ([p (in-list parents)])
|
|
(or (part-tag-prefix p) "")))))
|
|
|
|
(define/override (derive-filename d ci ri)
|
|
(let ([fn (format "~a.html"
|
|
(regexp-replace*
|
|
"[^-a-zA-Z0-9_=]"
|
|
(string-append
|
|
(append-part-prefixes d ci ri)
|
|
(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 (include-navigation?) #t)
|
|
|
|
(define/override (collect ds fns fp)
|
|
(super collect
|
|
ds
|
|
(map (lambda (fn) (build-path fn "index.html")) fns)
|
|
fp))
|
|
|
|
(define/override (current-part-whole-page? d)
|
|
(collecting-whole-page))
|
|
|
|
(define/override (start-collect ds fns ci)
|
|
(parameterize ([current-part-files (make-hash)])
|
|
(map (lambda (d fn)
|
|
(parameterize ([collecting-sub
|
|
(if (part-style? d 'non-toc)
|
|
1
|
|
0)])
|
|
(super start-collect (list d) (list fn) ci)))
|
|
ds
|
|
fns)))
|
|
|
|
(define/private (check-duplicate-filename orig-s)
|
|
(let ([s (string-downcase (path->string orig-s))])
|
|
(when (hash-ref (current-part-files) s #f)
|
|
(error 'htmls-render "multiple parts have the same filename (modulo case): ~e"
|
|
orig-s))
|
|
(hash-set! (current-part-files) s #t)))
|
|
|
|
(define/override (collect-part d parent ci number)
|
|
(let ([prev-sub (collecting-sub)])
|
|
(parameterize ([collecting-sub (if (toc-part? d)
|
|
1
|
|
(add1 prev-sub))]
|
|
[collecting-whole-page (prev-sub . <= . 1)])
|
|
(if (and (current-part-whole-page? d)
|
|
(not (eq? d (current-top-part))))
|
|
(let* ([filename (derive-filename d ci #f)]
|
|
[full-filename (build-path (path-only (current-output-file))
|
|
filename)])
|
|
(check-duplicate-filename full-filename)
|
|
(parameterize ([current-output-file full-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)]
|
|
[current-top-part d])
|
|
;; install files for each directory
|
|
(install-extra-files ds)
|
|
(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
|
|
extract-version)
|
|
|
|
(define/override (render-part d ri)
|
|
(parameterize ([current-version (extract-version d)])
|
|
(let ([number (collected-info-number (part-collected-info d ri))])
|
|
(if (and (on-separate-page-ok)
|
|
(part-whole-page? d ri)
|
|
(not (eq? d (current-top-part))))
|
|
;; Render as just a link, and put the actual content in a
|
|
;; new file:
|
|
(let* ([filename (derive-filename d #f ri)]
|
|
[full-path (build-path (path-only (current-output-file))
|
|
filename)])
|
|
(parameterize ([on-separate-page-ok #f])
|
|
;; We use 'replace instead of the usual 'truncate/replace
|
|
;; to avoid problems where a filename changes only in case,
|
|
;; in which case some platforms will see the old file
|
|
;; as matching the new name, while others don't. Replacing
|
|
;; the file syncs the case with the current uses.
|
|
(with-output-to-file full-path #:exists 'replace
|
|
(lambda () (render-one-part d ri full-path number)))
|
|
null))
|
|
(parameterize ([on-separate-page-ok #t])
|
|
;; Normal section render
|
|
(super render-part d ri))))))
|
|
|
|
(super-new)))
|
|
|
|
;; ----------------------------------------
|
|
;; utils
|
|
|
|
(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 in-plt?
|
|
(let ([roots (map explode (list (find-doc-dir) (find-collects-dir)))])
|
|
(lambda (path)
|
|
(ormap (lambda (root)
|
|
(let loop ([path path] [root root])
|
|
(or (null? root)
|
|
(and (pair? path)
|
|
(equal? (car path) (car root))
|
|
(loop (cdr path) (cdr root))))))
|
|
roots))))
|
|
|
|
(define exploded (make-weak-hash))
|
|
(define (explode/cache p)
|
|
(or (hash-ref exploded p #f)
|
|
(let ([v (explode p)])
|
|
(hash-set! exploded p v)
|
|
v)))
|
|
|
|
(define (from-root p d)
|
|
(define e-p (explode/cache (path->complete-path p (current-directory))))
|
|
(define e-d (and d (explode/cache (path->complete-path d (current-directory)))))
|
|
(define p-in? (in-plt? e-p))
|
|
(define d-in? (and d (in-plt? e-d)))
|
|
;; use an absolute link if the link is from outside the plt tree
|
|
;; going in (or if d is #f)
|
|
(if (not (and d (cond
|
|
[(equal? p-in? d-in?) #t]
|
|
[d-in? (error 'from-root
|
|
"got a link from the PLT tree going out; ~e"
|
|
p)]
|
|
[else #f])))
|
|
(url->string (path->url (path->complete-path p)))
|
|
(let loop ([e-d e-d] [e-p e-p])
|
|
(cond
|
|
[(null? e-d)
|
|
(string-append*
|
|
(let loop ([e-p e-p])
|
|
(cond [(null? e-p) '("/")]
|
|
[(null? (cdr e-p)) (list (car e-p))]
|
|
[(eq? 'same (car e-p)) (loop (cdr e-p))]
|
|
[(eq? 'up (car e-p)) (cons "../" (loop (cdr e-p)))]
|
|
[else (cons (car e-p) (cons "/" (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))]))))
|