#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 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)))

(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 ([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 ""))

(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]")
                   ,@(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")])
                   ,@(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))]
                    [number->decimal-string (lambda (s)
                                              (number->string
                                               (if (integer? s)
                                                   s
                                                   (exact->inexact s))))])
               (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"]))))))]
          [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
           [(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 `&rang;' and `&lang;' 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 "&#9001;" -- 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 "&#9002;" -- 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):
           ;;
           ;;   "&lang;": { "codepoints": [10216], "characters": "\u27E8" },
           ;;   "&rang;": { "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)
                    (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))))