154ffe21b5
When the search box is not present (e.g., https://docs.racket-lang.org/demo-m1/index.html), pressing "S" will result in a JS error. This PR fixes the problem. Note that semantically it makes more sense to give an ID to the search box as we know exactly what search box we want.
2096 lines
93 KiB
Racket
2096 lines
93 KiB
Racket
#lang scheme/base
|
|
(require "core.rkt"
|
|
"private/render-utils.rkt"
|
|
"html-properties.rkt"
|
|
"private/literal-anchor.rkt"
|
|
scheme/class
|
|
scheme/path
|
|
scheme/file
|
|
scheme/port
|
|
scheme/list
|
|
scheme/string
|
|
file/convertible
|
|
mzlib/runtime-path
|
|
setup/main-doc
|
|
setup/collects
|
|
setup/dirs
|
|
net/url
|
|
net/uri-codec
|
|
net/base64
|
|
scheme/serialize
|
|
racket/draw/gif
|
|
pkg/path
|
|
(prefix-in xml: xml/xml)
|
|
(for-syntax scheme/base)
|
|
"search.rkt"
|
|
(except-in "base.rkt" url))
|
|
(provide render-mixin
|
|
render-multi-mixin)
|
|
|
|
(define (number->decimal-string s)
|
|
(number->string (if (integer? s) s (exact->inexact s))))
|
|
|
|
(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)))))]
|
|
[adjust-rel
|
|
(lambda (depth p)
|
|
(if (and (relative-path? p)
|
|
(positive? depth))
|
|
(let loop ([d depth] [p p])
|
|
(if (zero? d)
|
|
p
|
|
(loop (sub1 d) (string-append "../" p))))
|
|
p))]
|
|
[file-getter
|
|
(lambda (default-file make-inline make-ref)
|
|
(let ([c #f])
|
|
(lambda (file path depth)
|
|
(cond [(bytes? file)
|
|
(make-inline (bytes->string/utf-8 file))]
|
|
[(url? file)
|
|
(make-ref (url->string* file))]
|
|
[(not (eq? 'inline path))
|
|
(make-ref (adjust-rel
|
|
depth
|
|
(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 current-render-convertible-requests (make-parameter '(png@2x-bytes png-bytes svg-bytes gif-bytes)))
|
|
|
|
(define (url->string* u)
|
|
(parameterize ([current-url-encode-mode 'unreserved])
|
|
(url->string u)))
|
|
|
|
;; HTML anchors should be case-insensitively unique. To make them
|
|
;; distinct, add a "." in front of capital letters. Also clean up
|
|
;; characters that give browsers trouble (i.e., the ones that are not
|
|
;; allowed as-is in URI components) 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 (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 (merge-styles s cls l)
|
|
;; merge multiple 'style and 'class attributes into one
|
|
(cond
|
|
[(null? l) (append
|
|
(if s
|
|
(list (list 'style s))
|
|
null)
|
|
(if cls
|
|
(list (list 'class cls))
|
|
null))]
|
|
[(eq? 'style (caar l))
|
|
(merge-styles (if s (string-append s "; " (cadar l)) (cadar l))
|
|
cls
|
|
(cdr l))]
|
|
[(eq? 'class (caar l))
|
|
(merge-styles s
|
|
(if cls (string-append cls " " (cadar l)) (cadar l))
|
|
(cdr l))]
|
|
[else (cons (car l) (merge-styles s cls (cdr l)))]))
|
|
|
|
(define (style->attribs style [extras null])
|
|
(let ([a (merge-styles
|
|
#f
|
|
#f
|
|
(apply
|
|
append
|
|
extras
|
|
(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)
|
|
(if (assq 'class a)
|
|
(for/list ([i (in-list a)])
|
|
(if (eq? (car i) 'class)
|
|
(list 'class (string-append name " " (cadr i)))
|
|
i))
|
|
(cons `[class ,name]
|
|
a))
|
|
a))))
|
|
|
|
;; combine a 'class attribute from both `cl' and `al'
|
|
;; if `cl' starts with one
|
|
(define (combine-class cl al)
|
|
(cond
|
|
[(and (pair? cl)
|
|
(eq? (caar cl) 'class)
|
|
(for/or ([i (in-list al)])
|
|
(and (eq? (car i) 'class) (cadr i))))
|
|
=> (lambda (s)
|
|
(cons
|
|
`[class ,(string-append (cadar cl) " " s)]
|
|
(append
|
|
(cdr cl)
|
|
(for/list ([i (in-list al)]
|
|
#:unless (eq? 'class (car i)))
|
|
i))))]
|
|
[else
|
|
(append cl al)]))
|
|
|
|
(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 ([emptylabel "...search manuals..."])
|
|
`(form ([class "searchform"])
|
|
(input
|
|
([class "searchbox"]
|
|
[id "searchbox"]
|
|
[type "text"]
|
|
[tabindex "1"]
|
|
[placeholder ,emptylabel]
|
|
[title "Enter a search string to search the manuals"]
|
|
[onkeypress ,(format "return DoSearchKey(event, this, ~s, ~s);"
|
|
(version) top-path)])))))
|
|
(define search-box (make-search-box "../"))
|
|
(define top-search-box (make-search-box ""))
|
|
|
|
(define (part-tags/nonempty p)
|
|
(define l (part-tags p))
|
|
(if (null? l)
|
|
(list `(part "???"))
|
|
l))
|
|
|
|
(define (part-parent d ri)
|
|
(collected-info-parent (part-collected-info d ri)))
|
|
|
|
(define (with-output-to-file/clean fn thunk)
|
|
;; 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-handlers ([exn? ; delete file on breaks, too
|
|
(lambda (exn)
|
|
(delete-file fn)
|
|
(raise exn))])
|
|
(with-output-to-file fn #:exists 'replace thunk)))
|
|
|
|
;; ----------------------------------------
|
|
;; main mixin
|
|
|
|
(define (render-mixin %)
|
|
(class %
|
|
(inherit render-block
|
|
render-part
|
|
collect-part
|
|
install-file
|
|
get-dest-directory
|
|
format-number
|
|
number-depth
|
|
quiet-table-of-contents
|
|
extract-part-style-files
|
|
extract-version
|
|
extract-authors
|
|
extract-pretitle
|
|
link-render-style-at-element)
|
|
(inherit-field prefix-file style-file style-extra-files image-preferences)
|
|
|
|
(init-field [alt-paths null]
|
|
;; `up-path' is either a link "up", or #t which goes
|
|
;; to the 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))
|
|
(define/override (skip-extra-file? p)
|
|
(lookup-path (if (path? p)
|
|
p
|
|
(collects-relative->path p))
|
|
alt-paths))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(inherit path->root-relative
|
|
root-relative->path
|
|
root-relative?)
|
|
|
|
(define path-cache (make-hash))
|
|
(define pkg-cache (make-hash))
|
|
|
|
(define (path->relative p)
|
|
(let ([p (path->main-doc-relative p)])
|
|
(if (path? p)
|
|
(let ([p (path->root-relative p)])
|
|
(if (path? p)
|
|
(let ([p (path->collects-relative p #:cache path-cache)])
|
|
(if (path? p)
|
|
p
|
|
(intern-taglet 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
|
|
(collects-relative->path p)))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define/override (start-collect ds fns ci)
|
|
(for-each (lambda (d fn)
|
|
(parameterize ([current-output-file fn]
|
|
[current-top-part d])
|
|
(collect-part d #f ci null 1 #hash())))
|
|
ds
|
|
fns))
|
|
|
|
(define/public (part-whole-page? p ri)
|
|
(let ([dest (resolve-get p ri (car (part-tags/nonempty p)))])
|
|
(and dest (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)
|
|
(define redirect (let ([s (part-style d)])
|
|
(and s
|
|
(for/or ([p (in-list (style-properties s))])
|
|
(and (part-link-redirect? p)
|
|
(part-link-redirect-url p))))))
|
|
(for ([t (part-tags d)])
|
|
(let ([key (generate-tag t ci)])
|
|
(collect-put! ci key
|
|
(let ([v (vector (or (part-title-content d) '("???"))
|
|
(add-current-tag-prefix key)
|
|
number
|
|
(and (current-output-file)
|
|
(path->relative (current-output-file)))
|
|
(current-part-whole-page? d))])
|
|
(if redirect
|
|
(list->vector (append (vector->list v)
|
|
(list (url->string* redirect))))
|
|
v))))))
|
|
|
|
(define/override (collect-target-element i ci)
|
|
(let ([key (generate-tag (target-element-tag i) ci)])
|
|
(collect-put! ci key
|
|
(vector (let ([tag (target-element-tag i)])
|
|
(if (and (pair? tag) (eq? 'part (car tag)))
|
|
(element-content i)
|
|
#f))
|
|
(if (redirect-target-element? i)
|
|
(make-literal-anchor
|
|
(redirect-target-element-alt-anchor i))
|
|
(add-current-tag-prefix key))
|
|
#f ; for consistency with 'part info
|
|
(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)))
|
|
(page-target-element? i)))))
|
|
|
|
(define (dest-path dest)
|
|
(vector-ref dest 3))
|
|
(define (dest-title dest)
|
|
(vector-ref dest 0))
|
|
(define (dest-number dest)
|
|
(vector-ref dest 2))
|
|
(define (dest-page? dest)
|
|
(vector-ref dest 4))
|
|
(define (dest-anchor dest)
|
|
(vector-ref dest 1))
|
|
(define (dest-redirect dest)
|
|
(if ((vector-length dest) . > . 5)
|
|
(vector-ref dest 5)
|
|
#f))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define external-tag-path #f)
|
|
(define/override (set-external-tag-path p)
|
|
(set! external-tag-path p))
|
|
|
|
(define external-root-url #f)
|
|
(define/override (set-external-root-url p)
|
|
(set! external-root-url p))
|
|
|
|
(define extra-script-files null)
|
|
(define/override (add-extra-script-file s)
|
|
(set! extra-script-files (cons s extra-script-files)))
|
|
|
|
(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/public (tag->url-string ri tag #:absolute? [abs? #f])
|
|
;; Called externally; not used internally
|
|
(let-values ([(dest ext?) (resolve-get/ext? #f ri tag)])
|
|
(cond [(not dest) ""]
|
|
[else (dest->url dest abs?)])))
|
|
|
|
(define/public (tag->query-string tag)
|
|
(define (simple? s)
|
|
(or (symbol? s)
|
|
(string? s)
|
|
(number? s)
|
|
(and (list? s) (andmap simple? s))))
|
|
(anchor-name (format "~s" (if (simple? tag)
|
|
tag
|
|
(serialize tag)))))
|
|
|
|
(define/private (link-element-indirect? e)
|
|
(memq 'indirect-link
|
|
(let ([s (element-style e)])
|
|
(or (and (style? s)
|
|
(style-properties s))
|
|
null))))
|
|
|
|
(define/override (resolve-content i d ri)
|
|
(cond
|
|
[(and (link-element? i)
|
|
external-tag-path
|
|
(link-element-indirect? i))
|
|
;; don't resolve indirect link
|
|
(resolve-content (element-content i) d ri)]
|
|
[else
|
|
(super resolve-content i d ri)]))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define/private (reveal-subparts? p) ;!!! need to use this
|
|
(part-style? p 'reveal))
|
|
|
|
(define/public (toc-wrap table)
|
|
null)
|
|
|
|
(define/private (dest->url dest [abs? #f])
|
|
(if dest
|
|
(or (dest-redirect dest)
|
|
(format "~a~a~a"
|
|
(let ([p (relative->path (dest-path dest))])
|
|
(if abs?
|
|
(path->url-string (path->complete-path p))
|
|
(if (equal? p (current-output-file))
|
|
""
|
|
(from-root p (get-dest-directory)))))
|
|
(if (dest-page? dest) "" "#")
|
|
(if (dest-page? dest)
|
|
""
|
|
(uri-unreserved-encode
|
|
(anchor-name (dest-anchor dest))))))
|
|
"???"))
|
|
|
|
(define/private (dest->url-in-doc dest ext-id)
|
|
(and dest
|
|
(not (dest-redirect dest))
|
|
(format "~a~a~a"
|
|
;; The path within the document directory is normally
|
|
;; just a single element, but detect nested paths
|
|
;; (for "r5rs-std", for example) when the containing
|
|
;; directory doesn't match `ext-id`:
|
|
(let loop ([path (relative->path (dest-path dest))]
|
|
[empty-ok? #f])
|
|
(let-values ([(base name dir?) (split-path path)])
|
|
(cond
|
|
[(and empty-ok?
|
|
dir?
|
|
(equal? (format "~a" name) (format "~a" ext-id)))
|
|
#f]
|
|
[(path? base)
|
|
(define r (loop base #t))
|
|
(if r (build-path r name) name)]
|
|
[else name])))
|
|
(if (dest-page? dest) "" "#")
|
|
(if (dest-page? dest)
|
|
""
|
|
(uri-unreserved-encode
|
|
(anchor-name (dest-anchor dest)))))))
|
|
|
|
(inherit sort-image-requests)
|
|
(define/override (render ds fns ri)
|
|
(parameterize ([current-render-convertible-requests
|
|
(sort-image-requests (current-render-convertible-requests)
|
|
image-preferences)])
|
|
(render-top ds fns ri)))
|
|
|
|
(define/public (render-top ds fns ri)
|
|
(super render ds fns ri))
|
|
|
|
(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/nonempty t))))]
|
|
[class ,(if (or (eq? t d) (and show-mine? (memq t toc-chain)))
|
|
"tocviewselflink"
|
|
"tocviewlink")]
|
|
[data-pltdoc "x"])
|
|
,@(render-content (strip-aux (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 ,(if top?
|
|
"tocviewlist tocviewlisttopspace"
|
|
"tocviewlist")])
|
|
,(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))))
|
|
,@(if (part-style? d 'no-sidebar)
|
|
null
|
|
(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 hidden-memo (make-weak-hasheq))
|
|
(define/public (all-toc-hidden? p)
|
|
(hash-ref hidden-memo
|
|
p
|
|
(lambda ()
|
|
(define h? (and (part-style? p 'toc-hidden)
|
|
(andmap (lambda (s) (all-toc-hidden? s))
|
|
(part-parts p))))
|
|
(hash-set! hidden-memo p h?)
|
|
h?)))
|
|
|
|
(define/private (render-onthispage-contents d ri top box-class sections-in-toc?)
|
|
(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 (or (nearly-top? d) (eq? d top)) values (lambda (p) (if (pair? p) (cdr p) null)))
|
|
(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 (or (nearly-top? d)
|
|
(part-style? d 'toc-hidden))
|
|
null
|
|
(list (vector d prefixes d)))
|
|
;; get internal targets:
|
|
(map (lambda (v) (vector v prefixes d)) (append-map block-targets (part-blocks d)))
|
|
(map (lambda (p) (if (or (part-whole-page? p ri)
|
|
(and (part-style? p 'toc-hidden)
|
|
(all-toc-hidden? p)))
|
|
null
|
|
(flatten p prefixes #f)))
|
|
(part-parts d)))))))
|
|
(define any-parts? (ormap (compose part? (lambda (p) (vector-ref p 0))) ps))
|
|
(if (null? ps)
|
|
null
|
|
`((div ([class ,box-class])
|
|
,@(get-onthispage-label)
|
|
(table ([class "tocsublist"] [cellspacing "0"])
|
|
,@(map (lambda (p)
|
|
(let ([p (vector-ref p 0)]
|
|
[prefixes (vector-ref p 1)]
|
|
[from-d (vector-ref p 2)]
|
|
[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)
|
|
from-d ri)
|
|
(parameterize ([current-no-links #t]
|
|
[extra-breaking? #t])
|
|
`((a ([href
|
|
,(format
|
|
"#~a"
|
|
(uri-unreserved-encode
|
|
(anchor-name
|
|
(add-tag-prefixes
|
|
(tag-key (if (part? p)
|
|
(car (part-tags/nonempty p))
|
|
(target-element-tag p))
|
|
ri)
|
|
prefixes))))]
|
|
[class
|
|
,(cond
|
|
[(part? p) "tocsubseclink"]
|
|
[any-parts? "tocsubnonseclink"]
|
|
[else "tocsublink"])]
|
|
[data-pltdoc "x"])
|
|
,@(render-content
|
|
(if (part? p)
|
|
(strip-aux
|
|
(or (part-title-content p)
|
|
"???"))
|
|
(if (toc-target2-element? p)
|
|
(toc-target2-element-toc-content p)
|
|
(element-content p)))
|
|
from-d ri)))))))))
|
|
ps)))))))
|
|
|
|
(define/private (extract-inherited d ri pred extract)
|
|
(or (ormap (lambda (v)
|
|
(and (pred v)
|
|
(extract v)))
|
|
(style-properties (part-style d)))
|
|
(let ([p (part-parent d ri)])
|
|
(and p (extract-inherited p ri pred extract)))))
|
|
|
|
(define/public (extract-part-body-id d ri)
|
|
(extract-inherited d ri body-id? body-id-value))
|
|
|
|
(define/public (extract-part-source d ri)
|
|
(extract-inherited d ri document-source? document-source-module-path))
|
|
|
|
(define/public (part-nesting-depth d ri)
|
|
0)
|
|
|
|
(define/public (render-one-part d ri fn number)
|
|
(parameterize ([current-output-file fn])
|
|
(let* ([defaults (let loop ([d d])
|
|
(or (ormap (lambda (v) (and (html-defaults? v) v))
|
|
(style-properties (part-style d)))
|
|
(let ([p (part-parent d ri)])
|
|
(and p (loop p)))))]
|
|
[prefix-file (or prefix-file
|
|
(and defaults
|
|
(let ([v (html-defaults-prefix-path defaults)])
|
|
(if (bytes? v)
|
|
v
|
|
(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
|
|
(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 (strip-aux c) this d ri)))]
|
|
[else `(title)])]
|
|
[dir-depth (part-nesting-depth d ri)]
|
|
[extract (lambda (pred get) (extract-part-style-files
|
|
d
|
|
ri
|
|
(lambda (p) (part-whole-page? p ri))
|
|
pred
|
|
get))])
|
|
(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-xexpr
|
|
`(html ,(style->attribs (part-style d))
|
|
(head ()
|
|
(meta ([http-equiv "content-type"]
|
|
[content "text/html; charset=utf-8"]))
|
|
(meta ([name "viewport"]
|
|
[content "width=device-width, initial-scale=0.8"]))
|
|
,title
|
|
,(scribble-css-contents scribble-css
|
|
(lookup-path scribble-css alt-paths)
|
|
dir-depth)
|
|
,@(map (lambda (style-file)
|
|
(if (or (bytes? style-file) (url? style-file))
|
|
(scribble-css-contents style-file #f dir-depth)
|
|
(let ([p (lookup-path style-file alt-paths)])
|
|
(unless p (install-file style-file))
|
|
(scribble-css-contents style-file p dir-depth))))
|
|
(append (extract css-addition? css-addition-path)
|
|
(list style-file)
|
|
(extract css-style-addition? css-style-addition-path)
|
|
style-extra-files))
|
|
,(scribble-js-contents script-file
|
|
(lookup-path script-file alt-paths)
|
|
dir-depth)
|
|
,@(map (lambda (script-file)
|
|
(if (or (bytes? script-file) (url? script-file))
|
|
(scribble-js-contents script-file #f dir-depth)
|
|
(let ([p (lookup-path script-file alt-paths)])
|
|
(unless p (install-file script-file))
|
|
(scribble-js-contents script-file p dir-depth))))
|
|
(append
|
|
(extract js-addition? js-addition-path)
|
|
(extract js-style-addition? js-style-addition-path)
|
|
(reverse extra-script-files)))
|
|
,(xml:comment "[if IE 6]><style type=\"text/css\">.SIEHidden { overflow: hidden; }</style><![endif]")
|
|
,@(extract head-addition? head-addition-xexpr)
|
|
,@(for/list ([p (style-properties (part-style d))]
|
|
#:when (head-extra? p))
|
|
(head-extra-xexpr p)))
|
|
(body ([id ,(or (extract-part-body-id d ri)
|
|
"scribble-racket-lang-org")])
|
|
,@(if (part-style? d 'no-toc+aux)
|
|
null
|
|
(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 (toc-part? d ri)
|
|
(and (part-style? d 'toc)
|
|
;; topmost part doesn't count as toc, since it
|
|
(part-parent 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 depth) "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 ri) (pair? (part-parts p)))
|
|
(loop (last (part-parts p)))
|
|
p))
|
|
(and parent (toc-part? parent ri) parent)))
|
|
(define next
|
|
(cond [(and (toc-part? d ri) (pair? (part-parts d))) (car (part-parts d))]
|
|
[(not next0)
|
|
(let loop ([p parent])
|
|
(and p
|
|
(toc-part? p ri)
|
|
(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/nonempty 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 (if (equal? url "")
|
|
"#"
|
|
url))
|
|
(make-attributes
|
|
`([title . ,(if title* (string-append label " to " title*) label)]
|
|
[data-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))
|
|
(list `(div ([class "nosearchform"]))))
|
|
,@(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/nonempty index))))
|
|
)))
|
|
(define navright
|
|
(if (not (or parent up-path next))
|
|
""
|
|
`(span ([class "navright"])
|
|
,@(render
|
|
;; put space here for text browsers and to avoid an Opera issue
|
|
sep-element
|
|
(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 ri)
|
|
(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")
|
|
v))
|
|
d
|
|
ri))))))
|
|
|
|
(define/public (extract-render-convertible-as d)
|
|
(for/or ([v (in-list (style-properties (part-style d)))])
|
|
(and (render-convertible-as? v)
|
|
(render-convertible-as-types v))))
|
|
|
|
(define/override (render-part-content d ri)
|
|
(parameterize ([current-render-convertible-requests (or (extract-render-convertible-as d)
|
|
(current-render-convertible-requests))])
|
|
(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 (number-depth number)
|
|
[(0) 'h2]
|
|
[(1) 'h3]
|
|
[(2) 'h4]
|
|
[else 'h5])
|
|
,(let ([src (extract-part-source d ri)]
|
|
[taglet (for/or ([t (in-list (part-tags d))])
|
|
(and (pair? t)
|
|
(eq? 'part (car t))
|
|
(= 2 (length t))
|
|
(cadr t)))])
|
|
(if (and src taglet)
|
|
`([x-source-module ,(format "~s" src)]
|
|
,@(let* ([path (resolved-module-path-name
|
|
(module-path-index-resolve
|
|
(module-path-index-join src #f)))]
|
|
[pkg (and (path? path)
|
|
(path->pkg path #:cache pkg-cache))])
|
|
(if pkg
|
|
`([x-source-pkg ,pkg])
|
|
null))
|
|
,@(let ([prefixes (current-tag-prefixes)])
|
|
(if (null? prefixes)
|
|
null
|
|
`([x-part-prefixes ,(format "~s" prefixes)])))
|
|
[x-part-tag ,(format "~s" taglet)])
|
|
'()))
|
|
,@(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))
|
|
[,@(combine-class
|
|
(case (style-name style)
|
|
[(author) '([class "author"])]
|
|
[(pretitle) '([class "SPretitle"])]
|
|
[(wraps) null]
|
|
[else null])
|
|
attrs)]
|
|
,@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 [extras null])
|
|
(let ([s (content-style e)])
|
|
(if (style? s)
|
|
(element-style->attribs (style-name s) s extras)
|
|
(element-style->attribs s #f extras))))
|
|
|
|
(define (element-style-property-matching e pred)
|
|
(and (or (element? e) (multiarg-element? e))
|
|
(ormap (lambda (v) (and (pred v) v))
|
|
(let ([s (if (element? e)
|
|
(element-style e)
|
|
(multiarg-element-style e))])
|
|
(if (style? s) (style-properties s) null)))))
|
|
|
|
(define/override (render-content e part ri)
|
|
(define (attribs [extras null]) (content-attribs e extras))
|
|
(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)
|
|
(render-as-convertible e (current-render-convertible-requests)))
|
|
=> values]
|
|
[(image-element? e)
|
|
(let* ([src (collects-relative->path (image-element-path e))]
|
|
[suffixes (image-element-suffixes e)]
|
|
[scale (image-element-scale e)]
|
|
[to-scaled-num
|
|
(lambda (s)
|
|
(number->string
|
|
(inexact->exact
|
|
(floor (* scale (if (number? s)
|
|
s
|
|
(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?
|
|
(define (to-scaled-num-from-str s)
|
|
(define parts
|
|
(regexp-match
|
|
#rx"^([+-]?[0-9]*\\.?([0-9]+)?)(em|ex|px|in|cm|mm|pt|pc|%|)$"
|
|
s))
|
|
(cond
|
|
[parts
|
|
(string-append
|
|
(number->string
|
|
(* scale
|
|
(string->number (list-ref parts 1))))
|
|
(list-ref parts 3))]
|
|
[else s]))
|
|
(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 ,(to-scaled-num-from-str w)]
|
|
[height ,(to-scaled-num-from-str h)])
|
|
null)))))]
|
|
[else
|
|
;; Try to extract file size:
|
|
(call-with-input-file*
|
|
src
|
|
(lambda (in)
|
|
(cond
|
|
[(regexp-try-match #px#"^\211PNG.{12}" in)
|
|
`([width ,(to-scaled-num (read-bytes 4 in))]
|
|
[height ,(to-scaled-num (read-bytes 4 in))])]
|
|
[(regexp-try-match #px#"^(?=GIF8)" in)
|
|
(define-values (w h rows) (gif->rgba-rows in))
|
|
`([width ,(to-scaled-num w)]
|
|
[height ,(to-scaled-num h)])]
|
|
[else
|
|
null])))])])
|
|
(let ([srcref (let ([p (install-file src)])
|
|
(if (path? p)
|
|
(url->string* (path->url (path->complete-path p)))
|
|
p))])
|
|
`((img
|
|
([src ,srcref]
|
|
[alt ,(content->string (element-content e))]
|
|
,@sz
|
|
,@(attribs))))))]
|
|
[(element-style-property-matching e script-property?)
|
|
=>
|
|
(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)))))]
|
|
[(element-style-property-matching e xexpr-property?)
|
|
=>
|
|
(lambda (v)
|
|
(cons (xexpr-property-before v)
|
|
(append (render-plain-content e part ri)
|
|
(list (xexpr-property-after v)))))]
|
|
[(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])
|
|
(define indirect-link? (link-element-indirect? e))
|
|
(let*-values ([(dest ext-id)
|
|
(if (and indirect-link?
|
|
external-tag-path)
|
|
(values #f #f)
|
|
(resolve-get/ext-id part ri (link-element-tag e)))]
|
|
[(number-link?)
|
|
(and dest
|
|
(not ext-id)
|
|
(let ([n (dest-number dest)])
|
|
;; If the section number is empty, don't generate an
|
|
;; empty link:
|
|
(not (or (not n)
|
|
(string=? "" (apply string-append (format-number n '("")))))))
|
|
(eq? 'number (link-render-style-at-element e))
|
|
(empty-content? (element-content e)))])
|
|
|
|
(if (or indirect-link? dest)
|
|
`(,@(cond
|
|
[number-link?
|
|
`(,(if (let ([s (element-style e)])
|
|
(and (style? s) (memq 'uppercase (style-properties s))))
|
|
"Section "
|
|
"section "))]
|
|
[else '()])
|
|
(a ([href
|
|
,(cond
|
|
[(and ext-id external-root-url dest
|
|
(let* ([ref-path (relative->path (dest-path dest))]
|
|
[rel (if (relative-path? ref-path)
|
|
#f
|
|
(find-relative-path
|
|
(find-doc-dir)
|
|
ref-path))])
|
|
(and rel
|
|
(relative-path? rel)
|
|
(not (memq 'up (explode-path rel)))
|
|
rel)))
|
|
=> (lambda (rel)
|
|
(url->string*
|
|
(struct-copy
|
|
url
|
|
(combine-url/relative
|
|
(string->url external-root-url)
|
|
(string-join (map (lambda (s)
|
|
(case s
|
|
[(up) ".."]
|
|
[(same) "."]
|
|
[else (path-element->string s)]))
|
|
(explode-path rel))
|
|
"/"))
|
|
[fragment
|
|
(and (not (dest-page? dest))
|
|
(anchor-name (dest-anchor dest)))])))]
|
|
[(or indirect-link?
|
|
(and ext-id external-tag-path))
|
|
;; Redirected to search:
|
|
(url->string*
|
|
(let ([u (string->url (or external-tag-path
|
|
(get-doc-search-url)))])
|
|
(struct-copy
|
|
url
|
|
u
|
|
[query
|
|
(if (string? ext-id)
|
|
(list* (cons 'doc ext-id)
|
|
(cons 'rel (or (dest->url-in-doc dest ext-id) "???"))
|
|
(url-query u))
|
|
(cons (cons 'tag (tag->query-string (link-element-tag e)))
|
|
(url-query u)))])))]
|
|
[else
|
|
;; Normal link:
|
|
(dest->url dest)])]
|
|
,@(attribs (if (or indirect-link?
|
|
(and ext-id external-tag-path))
|
|
'([class "Sq"])
|
|
null))
|
|
[data-pltdoc "x"])
|
|
,@(if (empty-content? (element-content e))
|
|
(cond
|
|
[number-link? (format-number (dest-number dest) '(""))]
|
|
[else
|
|
(render-content (strip-aux (dest-title dest)) part ri)])
|
|
(render-content (element-content e) part ri))))
|
|
(begin
|
|
(when #f
|
|
(eprintf "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
|
|
(render-plain-content e part ri)]))
|
|
|
|
(define/private (render-as-convertible e requests)
|
|
(for/or ([request (in-list requests)])
|
|
(cond
|
|
[(case request
|
|
[(png-bytes)
|
|
(or (convert e 'png-bytes+bounds8)
|
|
(convert e 'png-bytes+bounds)
|
|
(convert e 'png-bytes))]
|
|
[(png@2x-bytes)
|
|
(or (convert e 'png@2x-bytes+bounds8)
|
|
(convert e 'png@2x-bytes+bounds)
|
|
(convert e 'png@2x-bytes))]
|
|
[else #f])
|
|
=>
|
|
(lambda (cvt)
|
|
(let* ([bstr (if (list? cvt) (first cvt) cvt)]
|
|
[w (if (list? cvt)
|
|
(list-ref cvt 1)
|
|
(integer-bytes->integer (subbytes bstr 16 20) #f #t))]
|
|
[h (if (list? cvt)
|
|
(list-ref cvt 2)
|
|
(integer-bytes->integer (subbytes bstr 20 24) #f #t))]
|
|
[scale (lambda (v)
|
|
(if (and (not (list? cvt))
|
|
(equal? request 'png@2x-bytes))
|
|
(/ v 2.0)
|
|
v))])
|
|
(list
|
|
(add-padding
|
|
cvt
|
|
`(img ([src ,(install-file "pict.png" bstr)]
|
|
[alt "image"]
|
|
[width ,(number->decimal-string (scale w))]
|
|
[height ,(number->decimal-string (scale h))]))))))]
|
|
[(case request
|
|
[(svg-bytes)
|
|
(or (convert e 'svg-bytes+bounds8)
|
|
(convert e 'svg-bytes))]
|
|
[else #f])
|
|
=> (lambda (cvt)
|
|
(let* ([bstr (if (list? cvt) (first cvt) cvt)])
|
|
(list
|
|
(add-padding
|
|
cvt
|
|
`(img
|
|
([src ,(install-file "pict.svg" bstr)]
|
|
[type "image/svg+xml"]))))))]
|
|
[(and (equal? request 'gif-bytes) (convert e 'gif-bytes))
|
|
=>
|
|
(lambda (gif-bytes)
|
|
(define gif-src (install-file "pict.gif" gif-bytes))
|
|
|
|
;; GIFs store their width and height in the first 4 bytes of the logical screen
|
|
;; descriptor, which comes after the 6-byte long header block. The width and height are
|
|
;; each represented by 2-byte wide little-endian unsigned fields.
|
|
(define width (+ (bytes-ref gif-bytes 6) (* (bytes-ref gif-bytes 7) 256)))
|
|
(define height (+ (bytes-ref gif-bytes 8) (* (bytes-ref gif-bytes 9) 256)))
|
|
|
|
(define image-tag
|
|
`(img ([src ,gif-src]
|
|
[type "image/gif"]
|
|
[width ,(number->decimal-string width)]
|
|
[height ,(number->decimal-string height)])))
|
|
(list image-tag))]
|
|
[else #f])))
|
|
|
|
;; Add padding for a bounding-box conversion reply:
|
|
(define/private (add-padding cvt e)
|
|
(define descent (and (list? cvt)
|
|
((length cvt) . >= . 5)
|
|
(list-ref cvt 3)))
|
|
(define padding (and (list? cvt)
|
|
((length cvt) . >= . 9)
|
|
(take (list-tail cvt 5) 4)))
|
|
(cond
|
|
[(and (or (not descent)
|
|
(zero? descent))
|
|
(or (not padding)
|
|
(andmap zero? padding)))
|
|
e]
|
|
[else
|
|
;; Descent and padding:
|
|
(define-values (left top right bottom) (apply values padding))
|
|
`(,(car e) ,(cons `[style ,(format "vertical-align: ~apx; margin: ~apx ~apx ~apx ~apx;"
|
|
(- (- descent bottom))
|
|
(- top) (- right)
|
|
(- bottom) (- left))]
|
|
(cadr e))
|
|
,@(cddr e))]))
|
|
|
|
(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)))]
|
|
[resources (for/list ([p (in-list properties)]
|
|
#:when (install-resource? p))
|
|
(install-resource-path p))]
|
|
[link-resource (for/or ([p (in-list properties)]
|
|
#:when (link-resource? p))
|
|
(link-resource-path p))]
|
|
[link? (and (or (ormap target-url? properties)
|
|
link-resource)
|
|
(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)]
|
|
[check-render
|
|
(lambda ()
|
|
(when (render-element? e)
|
|
((render-element-render e) this part ri)))])
|
|
(for ([r (in-list resources)])
|
|
(install-file r))
|
|
(let-values ([(content) (cond
|
|
[link?
|
|
(parameterize ([current-no-links #t])
|
|
(super render-content e part ri))]
|
|
[newline? (check-render) null]
|
|
[(eq? 'hspace name)
|
|
(check-render)
|
|
(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])
|
|
,(append
|
|
(if link-resource
|
|
`([href ,(install-file link-resource)])
|
|
null)
|
|
attribs)
|
|
,@content))))))
|
|
|
|
(define/private (element-style->attribs name style [extras null])
|
|
(combine-class
|
|
(cond
|
|
[(symbol? name)
|
|
(case name
|
|
[(emph) '([class "emph"])]
|
|
[(italic) '([style "font-style: italic"])]
|
|
[(bold) '([style "font-weight: bold"])]
|
|
[(tt) '([class "stt"])]
|
|
[(roman) '([class "sroman"])]
|
|
[(url) '([class "url"])]
|
|
[(no-break) '([class "nobreak"])]
|
|
[(sf) '([class "ssansserif"])]
|
|
[(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 extras)
|
|
(if (pair? extras)
|
|
(style->attribs (make-style #f null) extras)
|
|
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 (lambda (a)
|
|
(or (attributes? a)
|
|
(color-property? a)
|
|
(background-color-property? a)))
|
|
(style-properties column-style)))
|
|
(let ([ps (style-properties column-style)])
|
|
(cond
|
|
[(memq 'border ps)
|
|
`([style "border: 1px solid black;"])]
|
|
[else
|
|
(define (check sym sfx)
|
|
(if (memq sym ps)
|
|
`([style ,(format "border-~a: 1px solid black;" sfx)])
|
|
null))
|
|
(append
|
|
(check 'top-border 'top)
|
|
(check 'bottom-border 'bottom)
|
|
(check 'left-border 'left)
|
|
(check 'right-border 'right))])))
|
|
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)))]))))
|
|
(define cell-styless (extract-table-cell-styles t))
|
|
`((table ([cellspacing "0"]
|
|
[cellpadding "0"]
|
|
,@(combine-class
|
|
(case (style-name (table-style t))
|
|
[(boxed) '([class "boxed"])]
|
|
[(centered) '([align "center"])]
|
|
[else '()])
|
|
(style->attribs (table-style t)
|
|
(append
|
|
(if starting-item?
|
|
'([style "display: inline-table; vertical-align: text-top; margin-top: 0;"])
|
|
null)
|
|
(if (for/or ([cell-styles (in-list cell-styless)])
|
|
(for/or ([cell-style (in-list cell-styles)])
|
|
(and cell-style
|
|
(let ([ps (style-properties cell-style)])
|
|
(or (memq 'border ps)
|
|
(memq 'left-border ps)
|
|
(memq 'right-border ps)
|
|
(memq 'bottom-border ps)
|
|
(memq 'top-border ps))))))
|
|
`([style "border-collapse: collapse;"])
|
|
'())))))
|
|
,@(let ([columns (ormap (lambda (p)
|
|
(and (table-columns? p)
|
|
(map (lambda (s)
|
|
(ormap (lambda (a)
|
|
(and (column-attributes? a)
|
|
a))
|
|
(style-properties s)))
|
|
(table-columns-styles p))))
|
|
(style-properties (table-style t)))])
|
|
(if (and columns (ormap values columns))
|
|
`((colgroup ,@(for/list ([col (in-list columns)])
|
|
`(col ,(if col
|
|
(map (lambda (v) (list (car v) (cdr v))) (column-attributes-assoc col))
|
|
null)))))
|
|
null))
|
|
,@(if (null? (table-blockss t))
|
|
`((tr (td)))
|
|
(map make-row
|
|
(table-blockss t)
|
|
cell-styless)))))
|
|
|
|
(define/override (render-nested-flow t part ri starting-item?)
|
|
`((,(or (style->tag (nested-flow-style t)) 'blockquote)
|
|
[,@(combine-class
|
|
(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])
|
|
(style->attribs (nested-flow-style t)))]
|
|
,@(apply append
|
|
(super render-nested-flow t part ri starting-item?)))))
|
|
|
|
(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 (and (string? (style-name (itemization-style t)))
|
|
(style-name (itemization-style t)))])
|
|
`((,(if (eq? 'ordered (style-name (itemization-style t)))
|
|
'ol
|
|
'ul)
|
|
(,@(style->attribs (itemization-style t))
|
|
,@(if (eq? 'compact (style-name (itemization-style t)))
|
|
`([class "compact"])
|
|
'()))
|
|
,@(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"]) " " nbsp))
|
|
(render-other (substring i (cdar m)) part ri))
|
|
(ascii-ize i)))]
|
|
[(symbol? i)
|
|
(case i
|
|
[(mdash) '(#x2014 (wbr))] ;; <wbr> encourages breaking after rather than before
|
|
|
|
;; FIXME: 'lang and 'rang do not match `⟩' and `⟨' in HTML 4 or 5.
|
|
;; Happened because of the thread:
|
|
;; <http://lists.racket-lang.org/users/archive/2008-June/025126.html>
|
|
;; ("Fonts with proper angle brackets")
|
|
;;
|
|
;; Do we still need this? See test page at <http://jsbin.com/okizeb/3>.
|
|
;;
|
|
;; More background:
|
|
;;
|
|
;; HTML 4 says (in HTMLsymbol.dtd):
|
|
;;
|
|
;; <!ENTITY lang CDATA "〈" -- left-pointing angle bracket = bra,
|
|
;; U+2329 ISOtech -->
|
|
;; <!-- lang is NOT the same character as U+003C 'less than'
|
|
;; or U+2039 'single left-pointing angle quotation mark' -->
|
|
;; <!ENTITY rang CDATA "〉" -- right-pointing angle bracket = ket,
|
|
;; U+232A ISOtech -->
|
|
;; <!-- rang is NOT the same character as U+003E 'greater than'
|
|
;; or U+203A 'single right-pointing angle quotation mark' -->
|
|
;;
|
|
;; HTML 5 says (in <https://github.com/w3c/html/raw/4b354c25cdc7025fef9f561bbc98fee2d9d241c1/entities.json>, dated 2012-10-12):
|
|
;;
|
|
;; "⟨": { "codepoints": [10216], "characters": "\u27E8" },
|
|
;; "⟩": { "codepoints": [10217], "characters": "\u27E9" },
|
|
;;
|
|
[(lang) '(#x2039)] ; SINGLE LEFT-POINTING ANGLE QUOTATION MARK
|
|
[(rang) '(#x203a)] ; SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
|
|
|
|
[else (list i)])]
|
|
[else
|
|
(log-error (format "Unrecognized element in content: ~e" i))
|
|
(list (format "~s" i))]))
|
|
|
|
(define/private (ascii-ize s)
|
|
(if (= (string-utf-8-length s) (string-length s))
|
|
(list 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?
|
|
all-toc-hidden?)
|
|
|
|
(define directory-depth 1)
|
|
(define/override (set-directory-depth n)
|
|
(set! directory-depth (max 1 n)))
|
|
|
|
(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 (part-nesting-depth d ri)
|
|
(min (part-depth d ri) (sub1 directory-depth)))
|
|
|
|
(define/private (part-depth d ri)
|
|
(define p (collected-info-parent (part-collected-info d ri)))
|
|
(if (not p)
|
|
0
|
|
(add1 (part-depth p ri))))
|
|
|
|
(define/override (derive-filename d ci ri depth)
|
|
(let ([base (regexp-replace*
|
|
"[^-a-zA-Z0-9_=]"
|
|
(string-append
|
|
(append-part-prefixes d ci ri)
|
|
(let ([s (cadr (car (part-tags/nonempty 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))])))
|
|
"_")])
|
|
(let ([fn (if (depth . < . directory-depth)
|
|
(path->string (build-path base "index.html"))
|
|
(format "~a.html" base))])
|
|
(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 [demand (lambda (key ci) #f)])
|
|
(super collect
|
|
ds
|
|
(map (lambda (fn) (build-path fn "index.html")) fns)
|
|
fp
|
|
demand))
|
|
|
|
(define/override (current-part-whole-page? d)
|
|
(collecting-whole-page))
|
|
|
|
(define/override (start-collect ds fns ci)
|
|
(parameterize ([current-part-files (make-hash)])
|
|
(for-each (lambda (d fn)
|
|
(check-duplicate-filename 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 sub-init-number sub-init-numberers)
|
|
(let ([prev-sub (collecting-sub)])
|
|
(parameterize ([collecting-sub (if (part-style? d 'toc)
|
|
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 (length number))]
|
|
[full-filename (build-path (path-only (current-output-file))
|
|
filename)])
|
|
(make-directory* (path-only full-filename))
|
|
(check-duplicate-filename full-filename)
|
|
(parameterize ([current-output-file full-filename])
|
|
(super collect-part d parent ci number sub-init-number sub-init-numberers)))
|
|
(super collect-part d parent ci number sub-init-number sub-init-numberers)))))
|
|
|
|
(define/override (render-top 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/clean
|
|
fn
|
|
(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))))
|
|
;; Put the actual content in a new file:
|
|
(let* ([filename (derive-filename d #f ri (part-depth d ri))]
|
|
[full-path (build-path (path-only (current-output-file))
|
|
filename)])
|
|
(parameterize ([on-separate-page-ok #f]
|
|
[current-subdirectory (let ([p (path-only filename)])
|
|
(if p
|
|
(build-path (current-subdirectory) p)
|
|
(current-subdirectory)))])
|
|
(with-output-to-file/clean
|
|
full-path
|
|
(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) (explode-path p))
|
|
|
|
(define in-plt?
|
|
(let ([roots (map explode (filter values (list (find-doc-dir) (find-collects-dir))))])
|
|
(lambda (path)
|
|
(for/or ([root (in-list roots)])
|
|
(let loop ([path path] [root root])
|
|
(or (null? root)
|
|
(and (pair? path)
|
|
(equal? (car path) (car root))
|
|
(loop (cdr path) (cdr root)))))))))
|
|
|
|
(define (from-root p d)
|
|
(define c-p (simplify-path (path->complete-path p)))
|
|
(define e-p (explode c-p))
|
|
(define e-d (and d (explode (simplify-path (path->complete-path d)))))
|
|
(define p-in? (in-plt? e-p))
|
|
(define d-in? (and d (in-plt? e-d)))
|
|
(define (normalize p) (normal-case-path p))
|
|
;; 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])
|
|
;; On Windows, need to be on the same drive, at least:
|
|
(equal? (normalize (car e-d))
|
|
(normalize (car e-p)))))
|
|
(path->url-string c-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 (path-element->string (car e-p)))]
|
|
[(eq? 'same (car e-p)) (loop (cdr e-p))]
|
|
[(eq? 'up (car e-p)) (cons "../" (loop (cdr e-p)))]
|
|
[else (cons (path-element->string (car e-p)) (cons "/" (loop (cdr e-p))))])))]
|
|
[(equal? (normalize (car e-d)) (normalize (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 (path->url-string p)
|
|
(if (eq? 'unix (path-convention-type p))
|
|
(let ([p (simplify-path p #f)])
|
|
(if (regexp-match? #rx#"^[-a-zA-Z0-9_/.]*$" (path->bytes p))
|
|
(string-append "file://" (path->string p))
|
|
(url->string (path->url p))))
|
|
(url->string (path->url p))))
|