#lang racket/base
(require "core.rkt"
         "private/render-utils.rkt"
         "html-properties.rkt"
         "private/literal-anchor.rkt"
         racket/class
         racket/path
         racket/file
         racket/port
         racket/list
         racket/string
         file/convertible
         mzlib/runtime-path
         setup/main-doc
         setup/collects
         setup/dirs
         net/url
         net/uri-codec
         net/base64
         racket/serialize
         racket/draw/gif
         pkg/path
         (prefix-in xml: xml/xml)
         (for-syntax racket/base)
         "search.rkt"
         (except-in "base.rkt" url))
(provide render-mixin
         render-multi-mixin)

(define (number->decimal-string s)
  (number->string (if (integer? s) s (exact->inexact s))))

(define as-literal
  (let ([loc (xml:make-location 0 0 0)])
    (lambda strings (xml:make-cdata loc loc (string-append* strings)))))
(define (ref-style path)
  `(link ([rel "stylesheet"] [type "text/css"] [href ,path] [title "default"])))
(define (inlined-style . body)
  `(style ([type "text/css"])
     ,(apply as-literal
             `("\n"
               ,@(map (lambda (x) (if (string? x) x (format "~a" x))) body)
               "\n"))))
(define (ref-script path)
  `(script ([type "text/javascript"] [src ,path])))
(define (inlined-script . body)
  `(script ([type "text/javascript"])
     ,(apply as-literal
             `("\n"
               ,@(map (lambda (x) (if (string? x) x (format "~a" x))) body)
               "\n"))))

(define-runtime-path scribble-css "scribble.css")
(define-runtime-path scribble-style-css "scribble-style.css")
(define-runtime-path scribble-prefix-html "scribble-prefix.html")
(define-runtime-path scribble-js  "scribble-common.js")
  utilities for render - one - part
(define-values (scribble-css-contents scribble-js-contents)
  (let* ([read-file
          (lambda (file)
            (with-input-from-file file
              (lambda ()
                ;; note: file-size can be bigger than the string, but
                ;; that's fine.
                (read-string (file-size file)))))]
         [adjust-rel
          (lambda (depth p)
            (if (and (relative-path? p)
                     (positive? depth))
                (let loop ([d depth] [p p])
                  (if (zero? d)
                      p
                      (loop (sub1 d) (string-append "../" p))))
                p))]
         [file-getter
          (lambda (default-file make-inline make-ref)
            (let ([c #f])
              (lambda (file path depth)
                (cond [(bytes? file)
                       (make-inline (bytes->string/utf-8 file))]
                      [(url? file)
                       (make-ref (url->string* file))]
                      [(not (eq? 'inline path))
                       (make-ref (adjust-rel
                                  depth
                                  (or path (let-values ([(base name dir?)
                                                         (split-path file)])
                                             (path->string name)))))]
                      [(or (not file) (equal? file default-file))
                       (unless c
                         (set! c (make-inline (read-file default-file))))
                       c]
                      [else (make-inline (read-file file))]))))])
    (values (file-getter scribble-css inlined-style  ref-style)
            (file-getter scribble-js  inlined-script ref-script))))

(define (lookup-path path mapping)
  (ormap (lambda (p)
           (and (equal? (car p) path)
                (cdr p)))
         mapping))

(define current-subdirectory (make-parameter #f))
(define current-output-file (make-parameter #f))
(define current-top-part (make-parameter #f))
(define on-separate-page-ok (make-parameter #t))
(define collecting-sub (make-parameter 0))
(define collecting-whole-page (make-parameter #t))
(define current-no-links (make-parameter #f))
(define extra-breaking? (make-parameter #f))
(define current-version (make-parameter (version)))
(define current-part-files (make-parameter #f))
(define current-render-convertible-requests (make-parameter '(png@2x-bytes png-bytes svg-bytes gif-bytes)))

(define (url->string* u)
  (parameterize ([current-url-encode-mode 'unreserved])
    (url->string u)))

;; HTML anchors should be case-insensitively unique. To make them
;;  distinct, add a "." in front of capital letters.  Also clean up
;;  characters that give browsers trouble (i.e., the ones that are not
   allowed as - is in URI components ) by using " ~ " followed by a hex
;;  encoding.  (The idea is that the result is still readable, so the
;;  link can be used as a rough indication of where you'll get to.)
(define (anchor-name v)
  (define (encode-byte b)
    (string-append (if (< b 16) "~0" "~") (number->string b 16)))
  (define (encode-bytes str)
    (string->bytes/utf-8 (encode-byte (bytes-ref str 0))))
  (if (literal-anchor? v)
    (literal-anchor-string v)
    (let* ([v (string->bytes/utf-8 (format "~a" v))]
           [v (regexp-replace* #rx#"[A-Z.]" v #".&")]
           [v (regexp-replace* #rx#" " v #"._")]
           [v (regexp-replace* #rx#"\"" v #".'")]
           [v (regexp-replace* #rx#"[^-a-zA-Z0-9_!+*'()/.,]" v encode-bytes)])
      (bytes->string/utf-8 v))))

(define (color->string c)
  (if (string? c)
      c
      (string-append*
       "#"
       (map (lambda (v)
              (let ([s (number->string v 16)])
                (if (< v 16) (string-append "0" s) s)))
            c))))

(define (merge-styles s cls l)
  merge multiple ' style and ' class attributes into one
  (cond
   [(null? l) (append
               (if s
                   (list (list 'style s))
                   null)
               (if cls
                   (list (list 'class cls))
                   null))]
   [(eq? 'style (caar l))
    (merge-styles (if s (string-append s "; " (cadar l)) (cadar l))
                  cls
                  (cdr l))]
   [(eq? 'class (caar l))
    (merge-styles s
                  (if cls (string-append cls " " (cadar l)) (cadar l))
                  (cdr l))]
   [else (cons (car l) (merge-styles s cls (cdr l)))]))

(define (style->attribs style [extras null])
  (let ([a (merge-styles
            #f
            #f
            (apply
             append
             extras
             (map (lambda (v)
                    (cond
                     [(attributes? v)
                      (map (lambda (v) (list (car v) (cdr v))) (attributes-assoc v))]
                     [(color-property? v)
                      `((style ,(format "color: ~a" (color->string (color-property-color v)))))]
                     [(background-color-property? v)
                      `((style ,(format "background-color: ~a" (color->string (background-color-property-color v)))))]
                     [(hover-property? v)
                      `((title ,(hover-property-text v)))]
                     [else null]))
                  (style-properties style))))])
    (let ([name (style-name style)])
      (if (string? name)
          (if (assq 'class a)
              (for/list ([i (in-list a)])
                (if (eq? (car i) 'class)
                    (list 'class (string-append name " " (cadr i)))
                    i))
              (cons `[class ,name]
                    a))
          a))))

;; combine a 'class attribute from both `cl' and `al'
   if ` cl ' starts with one
(define (combine-class cl al)
  (cond
   [(and (pair? cl)
         (eq? (caar cl) 'class)
         (for/or ([i (in-list al)])
           (and (eq? (car i) 'class) (cadr i))))
    => (lambda (s)
         (cons
          `[class ,(string-append (cadar cl) " " s)]
          (append
           (cdr cl)
           (for/list ([i (in-list al)]
                      #:unless (eq? 'class (car i)))
             i))))]
   [else
    (append cl al)]))

(define (style->tag style)
  (for/or ([s (in-list (style-properties style))])
    (and (alt-tag? s)
         (string->symbol (alt-tag-name s)))))

(define (make-search-box top-path) ; appears on every page
  (let ([emptylabel "...search manuals..."])
    `(form ([class "searchform"])
       (input
        ([class "searchbox"]
         [id "searchbox"]
         [type "text"]
         [tabindex "1"]
         [placeholder ,emptylabel]
         [title "Enter a search string to search the manuals"]
         [onkeypress ,(format "return DoSearchKey(event, this, ~s, ~s);"
                              (version) top-path)])))))
(define search-box (make-search-box "../"))
(define top-search-box (make-search-box ""))

(define (part-tags/nonempty p)
  (define l (part-tags p))
  (if (null? l)
      (list `(part "???"))
      l))

(define (part-parent d ri)
  (collected-info-parent (part-collected-info d ri)))

(define (with-output-to-file/clean fn thunk)
  ;; We use 'replace instead of the usual 'truncate/replace
  ;;  to avoid problems where a filename changes only in case,
  ;;  in which case some platforms will see the old file
  ;;  as matching the new name, while others don't. Replacing
  ;;  the file syncs the case with the current uses.
  (with-handlers ([exn? ; delete file on breaks, too
                   (lambda (exn)
                     (delete-file fn)
                     (raise exn))])
    (with-output-to-file fn #:exists 'replace thunk)))

;; ----------------------------------------
;;  main mixin

(define (render-mixin %)
  (class %
    (inherit render-block
             render-part
             collect-part
             install-file
             get-dest-directory
             format-number
             number-depth
             quiet-table-of-contents
             extract-part-style-files
             extract-version
             extract-authors
             extract-pretitle
             link-render-style-at-element)
    (inherit-field prefix-file style-file style-extra-files image-preferences)

    (init-field [alt-paths null]
                ;; `up-path' is either a link "up", or #t which goes
                ;; to the start page (using cookies to get to the
                ;; user start page). If it's a path, then it's also
                ;; used for the "top" link on the page.
                [up-path #f]
                [script-path #f]
                [script-file #f]
                [search-box? #f])

    (define/override (current-render-mode)
      '(html))

    (define/override (get-suffix) #".html")

    (define/override (index-manual-newlines?)
      #t)

    (define/override (auto-extra-files? v) (html-defaults? v))
    (define/override (auto-extra-files-paths v) (html-defaults-extra-files v))
    (define/override (skip-extra-file? p)
      (lookup-path (if (path? p)
                       p
                       (collects-relative->path p))
                   alt-paths))

    (define/private (install-file/as-url fn [content #f])
      (define p (install-file fn content))
      (if (relative-path? p)
          (relative-path->relative-url-string p)
          (url->string* (path->url (path->complete-path p)))))

    ;; ----------------------------------------

    (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  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)
            ;; Note: path is looked up and installed again below
            (unless (lookup-path style-file alt-paths) 
              (install-file style-file)))
          (define scribble-css-path
            (or (lookup-path scribble-css alt-paths) 
                (install-file/as-url scribble-css)))
          (define script-file-path
            (or (lookup-path script-file alt-paths) 
                (install-file/as-url 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
                                           scribble-css-path
                                           dir-depth)
                   ,@(map (lambda (style-file)
                            (if (or (bytes? style-file) (url? style-file))
                                (scribble-css-contents style-file #f dir-depth)
                                (let ([p (or (lookup-path style-file alt-paths)
                                             (install-file/as-url 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
                                          script-file-path
                                          dir-depth)
                   ,@(map (lambda (script-file)
                            (if (or (bytes? script-file) (url? script-file))
                                (scribble-js-contents script-file #f dir-depth)
                                (let ([p (or (lookup-path script-file alt-paths)
                                             (install-file/as-url script-file))])
                                  (scribble-js-contents script-file p dir-depth))))
                          (append
                           (extract js-addition? js-addition-path)
                           (extract js-style-addition? js-style-addition-path)
                           (reverse extra-script-files)))
                   ,(xml:comment "[if IE 6]><style type=\"text/css\">.SIEHidden { overflow: hidden; }</style><![endif]")
                   ,@(extract head-addition? head-addition-xexpr)
                   ,@(for/list ([p (style-properties (part-style d))]
                                #:when (head-extra? p))
                       (head-extra-xexpr p)))
                 (body ([id ,(or (extract-part-body-id d ri)
                                 "scribble-racket-lang-org")])
                   ,@(if (part-style? d 'no-toc+aux)
                         null
                         (render-toc-view d ri))
                   (div ([class "maincolumn"])
                     (div ([class "main"])
                       ,@(parameterize ([current-version (extract-version d)])
                           (render-version d ri))
                       ,@(navigation d ri #t)
                       ,@(render-part d ri)
                       ,@(navigation d ri #f)))
                   (div ([id "contextindicator"]) nbsp))))))))

    (define (toc-part? d ri)
      (and (part-style? d 'toc)
           ;; topmost part doesn't count as toc, since it
           (part-parent d ri)))

    (define/private (find-siblings d ri)
      (let ([parent (collected-info-parent (part-collected-info d ri))])
        (let loop ([l (cond
                        [parent (part-parts parent)]
                        [(or (null? (part-parts d))
                             (not (part-whole-page? (car (part-parts d)) ri)))
                         (list d)]
                        [else (list d (car (part-parts d)))])]
                   [prev #f])
          (if (eq? (car l) d)
            (values prev (and (pair? (cdr l)) (cadr l)))
            (loop (cdr l) (car l))))))

    (define top-content      "top")
    (define contents-content "contents")
    (define index-content    "index")
    (define prev-content     '(larr " prev"))
    (define up-content       "up")
    (define next-content     '("next " rarr))
    (define sep-element      '(nbsp nbsp))

    (define/public (derive-filename d ci ri depth) "bad.html")

    (define/public (include-navigation?) search-box?)

    (define/private (navigation d ri top?)
      (define parent (part-parent d ri))
      (define-values (prev0 next0) (find-siblings d ri))
      (define prev
        (if prev0
          (let loop ([p prev0])
            (if (and (toc-part? p ri) (pair? (part-parts p)))
              (loop (last (part-parts p)))
              p))
          (and parent (toc-part? parent ri) parent)))
      (define next
        (cond [(and (toc-part? d ri) (pair? (part-parts d))) (car (part-parts d))]
              [(not next0)
               (let loop ([p parent])
                 (and p 
                      (toc-part? p ri)
                      (let-values ([(prev next) (find-siblings p ri)])
                        (or next
                            (loop (part-parent p ri))))))]
              [else next0]))
      (define index
        (let loop ([d d])
          (let ([p (part-parent d ri)])
            (if p
              (loop p)
              (let ([subs (part-parts d)])
                (and (pair? subs)
                     (let ([d (last subs)])
                       (and (eq? (style-name (part-style d)) 'index)
                            d))))))))
      (define (render . content)
        (render-content (filter values content) d ri))
      (define (titled-url label x #:title-from [tfrom #f] . more)
        (define-values (url title)
          (cond [(part? x)
                 (values
                  (dest->url (resolve-get x ri (car (part-tags/nonempty x))))
                  (string-append
                   "\""
                   (content->string
                    (append (format-number (collected-info-number
                                            (part-collected-info x ri))
                                           '(" "))
                            (part-title-content x)))
                   "\""))]
                [(equal? x "index.html") (values x "the manual top")]
                [(equal? x "../index.html") (values x "the documentation top")]
                [(string? x) (values x #f)]
                [(path? x) (values (url->string* (path->url x)) #f)]
                [else (error 'navigation "internal error ~e" x)]))
        (define title*
          (if (and tfrom (part? tfrom))
            (string-append
             "\"" (content->string (part-title-content tfrom)) "\"")
            title))
        (make-style
         #f
         (list
          (make-target-url (if (equal? url "")
                               "#"
                               url))
          (make-attributes
           `([title . ,(if title* (string-append label " to " title*) label)]
             [data-pltdoc . "x"]
             ,@more)))))
      (define top-link
        (titled-url
         "up" (if (path? up-path)
                  (url->string* (path->url up-path))
                  "../index.html")
         `[onclick . ,(format "return GotoPLTRoot(\"~a\");" (version))]))
      (define tocset-toggle
        (make-element "tocsettoggle"
                      (list
                       sep-element
                       (make-element
                        (make-style #f (list
                                        (make-target-url "javascript:void(0);")
                                        (make-attributes
                                         '([title . "show/hide table of contents"]
                                           [onclick . "TocsetToggle();"]))))
                        "contents"))))
      (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))
              tocset-toggle
              ;; 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 (install-file/as-url src)])
             `((img
                ([src ,srcref]
                 [alt ,(content->string (element-content e))]
                 ,@sz
                 ,@(attribs))))))]
        [(element-style-property-matching e script-property?)
         => 
         (lambda (v)
           (let* ([t `[type ,(script-property-type v)]]
                  [s (script-property-script v)]
                  [s (if (list? s)
                         `(script (,t ,@(attribs)) ,(apply as-literal `("\n" ,@s "\n")))
                         `(script (,t ,@(attribs) [src ,s])))])
             (list s
                   `(noscript ,@(render-plain-content e part ri)))))]
        [(element-style-property-matching e xexpr-property?)
         =>
         (lambda (v)
           (cons (xexpr-property-before v)
                 (append (render-plain-content e part ri)
                         (list (xexpr-property-after v)))))]
        [(target-element? e)
         `((a ([name ,(format "~a" (anchor-name (add-current-tag-prefix
                                                 (tag-key (target-element-tag e)
                                                          ri))))]
               ,@(attribs)))
           ,@(render-content (element-content e) part ri))]
        [(and (link-element? e) (not (current-no-links)))
         (parameterize ([current-no-links #t])
           (define indirect-link? (link-element-indirect? e))
           (let*-values ([(dest ext-id)
                          (if (and indirect-link?
                                   external-tag-path)
                              (values #f #f)
                              (resolve-get/ext-id part ri (link-element-tag e)))]
                         [(number-link?)
                          (and dest
                               (not ext-id)
                               (let ([n (dest-number dest)])
                                 ;; If the section number is empty, don't generate an
                                 ;; empty link:
                                 (not (or (not n)
                                          (string=? "" (apply string-append (format-number n '("")))))))
                               (eq? 'number (link-render-style-at-element e))
                               (empty-content? (element-content e)))])
             
             (if (or indirect-link? dest)
                 `(,@(cond
                       [number-link?
                        `(,(if (let ([s (element-style e)])
                                 (and (style? s) (memq 'uppercase (style-properties s))))
                               "Section "
                               "section "))]
                       [else '()])
                   (a ([href
                      ,(cond
                        [(and ext-id external-root-url dest
                              (let* ([ref-path (relative->path (dest-path dest))]
                                     [rel (if (relative-path? ref-path)
                                              #f
                                              (find-relative-path
                                               (find-doc-dir)
                                               ref-path))])
                                (and rel
                                     (relative-path? rel)
                                     (not (memq 'up (explode-path rel)))
                                     rel)))
                         => (lambda (rel)
                              (url->string*
                               (struct-copy
                                url
                                (combine-url/relative
                                 (string->url external-root-url)
                                 (string-join (map (lambda (s)
                                                     (case s
                                                       [(up) ".."]
                                                       [(same) "."]
                                                       [else (path-element->string s)]))
                                                   (explode-path rel))
                                              "/"))
                                [fragment
                                 (and (not (dest-page? dest))
                                      (anchor-name (dest-anchor dest)))])))]
                        [(or indirect-link?
                             (and ext-id external-tag-path))
                         ;; Redirected to search:
                         (url->string*
                          (let ([u (string->url (or external-tag-path
                                                    (get-doc-search-url)))])
                            (struct-copy
                             url
                             u
                             [query
                              (if (string? ext-id)
                                  (list* (cons 'doc ext-id)
                                         (cons 'rel (or (dest->url-in-doc dest ext-id) "???"))
                                         (url-query u))
                                  (cons (cons 'tag (tag->query-string (link-element-tag e)))
                                        (url-query u)))])))]
                        [else
                         ;; Normal link:
                         (dest->url dest)])]
                     ,@(attribs (if (or indirect-link?
                                        (and ext-id external-tag-path))
                                    '([class "Sq"])
                                    null))
                     [data-pltdoc "x"])
                    ,@(if (empty-content? (element-content e))
                          (cond
                            [number-link? (format-number (dest-number dest) '(""))]
                            [else
                             (render-content (strip-aux (dest-title dest)) part ri)])
                          (render-content (element-content e) part ri))))
               (begin
                 (when #f
                   (eprintf "Undefined link: ~s\n"
                            (tag-key (link-element-tag e) ri)))
                 `((font ([class "badlink"])
                     ,@(if (empty-content? (element-content e))
                         `(,(format "~s" (tag-key (link-element-tag e) ri)))
                         (render-plain-content e part ri))))))))]
        [else 
         (render-plain-content e part ri)]))
    
    (define/private (render-as-convertible e requests)
      (for/or ([request (in-list requests)])
        (cond
          [(case request
             [(png-bytes)
              (or (convert e 'png-bytes+bounds8)
                  (convert e 'png-bytes+bounds)
                  (convert e 'png-bytes))]
             [(png@2x-bytes)
              (or (convert e 'png@2x-bytes+bounds8)
                  (convert e 'png@2x-bytes+bounds)
                  (convert e 'png@2x-bytes))]
             [else #f])
           => 
           (lambda (cvt)
             (let* ([bstr (if (list? cvt) (first cvt) cvt)]
                    [w (if (list? cvt)
                           (list-ref cvt 1)
                           (integer-bytes->integer (subbytes bstr 16 20) #f #t))]
                    [h (if (list? cvt)
                           (list-ref cvt 2)
                           (integer-bytes->integer (subbytes bstr 20 24) #f #t))]
                    [scale (lambda (v)
                             (if (and (not (list? cvt))
                                      (equal? request 'png@2x-bytes))
                                 (/ v 2.0)
                                 v))])
               (list
                (add-padding
                 cvt
                 `(img ([src ,(install-file/as-url "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/as-url "pict.svg" bstr)]
                       [type "image/svg+xml"]))))))]
          [(and (equal? request 'gif-bytes) (convert e 'gif-bytes))
           =>
           (lambda (gif-bytes)
             (define gif-src (install-file/as-url "pict.gif" gif-bytes))

  GIFs store their width and height in the first 4 bytes of the logical screen
  descriptor , which comes after the 6 - byte long header block . The width and height are
  each represented by 2 - byte wide little - endian unsigned fields .
             (define width (+ (bytes-ref gif-bytes 6) (* (bytes-ref gif-bytes 7) 256)))
             (define height (+ (bytes-ref gif-bytes 8) (* (bytes-ref gif-bytes 9) 256)))

             (define image-tag
               `(img ([src ,gif-src]
                      [type "image/gif"]
                      [width ,(number->decimal-string width)]
                      [height ,(number->decimal-string height)])))
             (list image-tag))]
          [else #f])))

    ;; Add padding for a bounding-box conversion reply:
    (define/private (add-padding cvt e)
      (define descent (and (list? cvt)
                           ((length cvt) . >= . 5)
                           (list-ref cvt 3)))
      (define padding (and (list? cvt)
                           ((length cvt) . >= . 9)
                           (take (list-tail cvt 5) 4)))
      (cond
       [(and (or (not descent)
                 (zero? descent))
             (or (not padding)
                 (andmap zero? padding)))
        e]
       [else
        ;; Descent and padding:
        (define-values (left top right bottom) (apply values padding))
        `(,(car e) ,(cons `[style ,(format "vertical-align: ~apx; margin: ~apx ~apx ~apx ~apx;"
                                           (- (- descent bottom))
                                           (- top) (- right)
                                           (- bottom) (- left))]
                          (cadr e))
          ,@(cddr e))]))

    (define/private (render-plain-content e part ri)
      (define (attribs) (content-attribs e))
      (let* ([properties (let ([s (content-style e)])
                           (if (style? s)
                               (style-properties s)
                               null))]
             [name (let ([s (content-style e)])
                     (if (style? s)
                         (style-name s)
                         s))]
             [alt-tag
              (let ([s (content-style e)])
                (and (style? s)
                     (style->tag s)))]
             [resources (for/list ([p (in-list properties)]
                                   #:when (install-resource? p))
                          (install-resource-path p))]
             [link-resource (for/or ([p (in-list properties)]
                                     #:when (link-resource? p))
                              (link-resource-path p))]
             [link? (and (or (ormap target-url? properties)
                             link-resource)
                         (not (current-no-links)))]
             [anchor? (ormap url-anchor? properties)]
             [attribs
              (append
               (if (null? properties)
                   null
                   (append-map (lambda (v)
                                 (cond
                                  [(target-url? v)
                                   (if (current-no-links)
                                       null
                                       `([href ,(let ([addr (target-url-addr v)])
                                                  (if (path? addr)
                                                      (from-root addr (get-dest-directory))
                                                      addr))]))]
                                  [else null]))
                               properties))
               (attribs))]
             [newline? (eq? name 'newline)]
             [check-render
              (lambda ()
                (when (render-element? e)
                  ((render-element-render e) this part ri)))])
        (for ([r (in-list resources)])
          (install-file r))
        (let-values ([(content) (cond
                                 [link?
                                  (parameterize ([current-no-links #t])
                                    (super render-content e part ri))]
                                 [newline? (check-render) null]
                                 [(eq? 'hspace name)
                                  (check-render)
                                  (let ([str (content->string e)])
                                    (map (lambda (c) 'nbsp) (string->list str)))]
                                 [else
                                  (super render-content e part ri)])])
          (if (and (null? attribs) 
                   (not link?)
                   (not anchor?)
                   (not newline?)
                   (not alt-tag))
              content
              `(,@(if anchor?
                      (append-map (lambda (v)
                                    (if (url-anchor? v)
                                        `((a ([name ,(url-anchor-name v)])))
                                        null))
                                  properties)
                      null)
                (,(cond
                   [alt-tag alt-tag]
                   [link? 'a]
                   [newline? 'br]
                   [else 'span]) 
                 ,(append
                   (if link-resource
                       `([href ,(install-file/as-url link-resource)])
                       null)
                   attribs)
                 ,@content))))))

    (define/private (element-style->attribs name style [extras null])
      (combine-class
       (cond
        [(symbol? name)
         (case name
           [(emph) '([class "emph"])]
           [(italic) '([style "font-style: italic"])]
           [(bold) '([style "font-weight: bold"])]
           [(tt) '([class "stt"])]
           [(roman) '([class "sroman"])]
           [(url) '([class "url"])]
           [(no-break) '([class "nobreak"])]
           [(sf) '([class "ssansserif"])]
           [(superscript) '([style "vertical-align: super; font-size: 80%"])]
           [(subscript) '([style "vertical-align: sub; font-size: 80%"])]
           [(smaller) '([class "Smaller"])]
           [(larger) '([class "Larger"])]
           [(hspace) '([class "hspace"])]
           [(newline) '()]
           [else (error 'html-render "unrecognized style symbol: ~e" name)])]
        [(string? name) (if style null `([class ,name]))]
        [else null])
       (if style
           (style->attribs style extras)
           (if (pair? extras)
               (style->attribs (make-style #f null) extras)
               null))))

    (define/override (render-table t part ri starting-item?)
      (define (make-row flows column-styles)
        `(tr
          ,@(let loop ([ds flows]
                       [column-styles column-styles]
                       [first? #t])
              (cond
               [(null? ds) null]
               [(eq? (car ds) 'cont)
                (loop (cdr ds) (cdr column-styles) first?)]
               [else
                (let ([d (car ds)] [column-style (car column-styles)])
                  (cons
                   `(td (,@(cond
                            [(not column-style) null]
                            [(memq 'right (style-properties column-style)) '([align "right"])]
                            [(memq 'left (style-properties column-style)) '([align "left"])]
                            [(memq 'center (style-properties column-style)) '([align "center"])]
                            [else null])
                         ,@(cond
                            [(not column-style) null]
                            [(memq 'top (style-properties column-style)) '([valign "top"])]
                            [(memq 'baseline (style-properties column-style)) '([valign "baseline"])]
                            [(memq 'vcenter (style-properties column-style)) '([valign "center"])]
                            [(memq 'bottom (style-properties column-style)) '([valign "bottom"])]
                            [else null])
                         ,@(if (and column-style
                                    (string? (style-name column-style)))
                               `([class ,(style-name column-style)])
                               null)
                         ,@(if (and column-style
                                    (pair? (style-properties column-style)))
                               (style->attribs (make-style
                                                #f
                                                (filter (lambda (a)
                                                          (or (attributes? a)
                                                              (color-property? a)
                                                              (background-color-property? a)))
                                                        (style-properties column-style)))
                                               (let ([ps (style-properties column-style)])
                                                 (cond
                                                  [(memq 'border ps)
                                                   `([style "border: 1px solid black;"])]
                                                  [else
                                                   (define (check sym sfx)
                                                     (if (memq sym ps)
                                                         `([style ,(format "border-~a: 1px solid black;" sfx)])
                                                         null))
                                                   (append
                                                    (check 'top-border 'top)
                                                    (check 'bottom-border 'bottom)
                                                    (check 'left-border 'left)
                                                    (check 'right-border 'right))])))
                               null)
                         ,@(if (and (pair? (cdr ds))
                                    (eq? 'cont (cadr ds)))
                               `([colspan
                                  ,(number->string
                                    (let loop ([n 2] [ds (cddr ds)])
                                      (cond [(null? ds) n]
                                            [(eq? 'cont (car ds))
                                             (loop (+ n 1) (cdr ds))]
                                            [else n])))])
                               null))
                        ,@(if (and (paragraph? d)
                                   (memq 'omitable (style-properties (paragraph-style d))))
                              (render-content (paragraph-content d) part ri)
                              (render-block d part ri #f)))
                   (loop (cdr ds) (cdr column-styles) #f)))]))))
      (define cell-styless (extract-table-cell-styles t))
      `((table ([cellspacing "0"]
                [cellpadding "0"]
                ,@(combine-class
                   (case (style-name (table-style t))
                     [(boxed)    '([class "boxed"])]
                     [(centered) '([align "center"])]
                     [else '()])
                   (style->attribs (table-style t)
                                   (append
                                    (if starting-item?
                                        '([style "display: inline-table; vertical-align: text-top; margin-top: 0;"])
                                        null)
                                    (if (for/or ([cell-styles (in-list cell-styless)])
                                          (for/or ([cell-style (in-list cell-styles)])
                                            (and cell-style
                                                 (let ([ps (style-properties cell-style)])
                                                   (or (memq 'border ps)
                                                       (memq 'left-border ps)
                                                       (memq 'right-border ps)
                                                       (memq 'bottom-border ps)
                                                       (memq 'top-border ps))))))
                                        `([style "border-collapse: collapse;"])
                                        '())))))
          ,@(let ([columns (ormap (lambda (p)
                                    (and (table-columns? p)
                                         (map (lambda (s)
                                                (ormap (lambda (a)
                                                         (and (column-attributes? a)
                                                              a))
                                                       (style-properties s)))
                                              (table-columns-styles p))))
                                  (style-properties (table-style t)))])
              (if (and columns (ormap values columns))
                  `((colgroup ,@(for/list ([col (in-list columns)])
                                  `(col ,(if col
                                             (map (lambda (v) (list (car v) (cdr v))) (column-attributes-assoc col))
                                             null)))))
                  null))
          ,@(if (null? (table-blockss t))
                `((tr (td)))
                (map make-row
                     (table-blockss t)
                     cell-styless)))))

    (define/override (render-nested-flow t part ri starting-item?)
      `((,(or (style->tag (nested-flow-style t)) 'blockquote)
         [,@(combine-class
             (cond
              [(eq? 'code-inset (style-name (nested-flow-style t)))
               `([class "SCodeFlow"])]
              [(eq? 'vertical-inset (style-name (nested-flow-style t)))
               `([class "SVInsetFlow"])]
              [(and (not (string? (style-name (nested-flow-style t))))
                    (not (eq? 'inset (style-name (nested-flow-style t)))))
               `([class "SubFlow"])]
              [else null])
             (style->attribs (nested-flow-style t)))]
         ,@(apply append
                  (super render-nested-flow t part ri starting-item?)))))

    (define/override (render-compound-paragraph t part ri starting-item?)
      (let ([style (compound-paragraph-style t)])
        `((,(or (style->tag style) 'p)
           ,(style->attribs style)
           ,@(super render-compound-paragraph t part ri starting-item?)))))

    (define/override (render-itemization t part ri)
      (let ([style-str (and (string? (style-name (itemization-style t)))
                            (style-name (itemization-style t)))])
        `((,(if (eq? 'ordered (style-name (itemization-style t)))
                'ol
                'ul)
           (,@(style->attribs (itemization-style t))
            ,@(if (eq? 'compact (style-name (itemization-style t)))
                  `([class "compact"])
                  '()))
           ,@(map (lambda (flow) `(li ,(if style-str
                                           `([class ,(string-append style-str "Item")])
                                           `())
                                      ,@(render-flow flow part ri #t)))
                  (itemization-blockss t))))))

    (define/override (render-other i part ri)
      (cond
        [(string? i)
         (let ([m (and (extra-breaking?)
                       (regexp-match-positions #rx"[-:/+_](?=.)|[a-z](?=[A-Z])" i))])
           (if m
             (list* (substring i 0 (cdar m))
                    ;; Most browsers wrap after a hyphen. The one that
  does n't , Firefox , pays attention to wbr .   Some
  browsers ignore wbr , but at least they do n'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
  < 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:
           ;;   <-lang.org/users/archive/2008-June/025126.html>
  ( " Fonts with proper angle brackets " )
           ;;
           ;; Do we still need this?  See test page at <>.
           ;; 
           ;; More background:
           ;;
  HTML 4 says ( in HTMLsymbol.dtd ):
           ;;
  < ! ENTITY lang      CDATA " & # 9001 ; " -- left - pointing angle bracket = bra ,
                                       U+2329 ISOtech -- >
  < !   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 <  > , 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)
                    (check-duplicate-filename fn)
                    (parameterize ([collecting-sub
                                    (if (part-style? d 'non-toc)
                                        1
                                        0)])
                      (super start-collect (list d) (list fn) ci)))
                  ds
                  fns)))

    (define/private (check-duplicate-filename orig-s)
      (let ([s (string-downcase (path->string orig-s))])
        (when (hash-ref (current-part-files) s #f)
          (error 'htmls-render "multiple parts have the same filename (modulo case): ~e"
                 orig-s))
        (hash-set! (current-part-files) s #t)))

    (define/override (collect-part d parent ci number sub-init-number sub-init-numberers)
      (let ([prev-sub (collecting-sub)])
        (parameterize ([collecting-sub (if (part-style? d 'toc)
                                           1 
                                           (add1 prev-sub))]
                       [collecting-whole-page (prev-sub . <= . 1)])
          (if (and (current-part-whole-page? d)
                   (not (eq? d (current-top-part))))
              (let* ([filename (derive-filename d ci #f (length number))]
                     [full-filename (build-path (path-only (current-output-file))
                                                filename)])
                (make-directory* (path-only full-filename))
                (check-duplicate-filename full-filename)
                (parameterize ([current-output-file full-filename])
                  (super collect-part d parent ci number sub-init-number sub-init-numberers)))
              (super collect-part d parent ci number sub-init-number sub-init-numberers)))))

    (define/override (render-top ds fns ri)
      (map (lambda (d fn)
             (when (report-output?)
               (printf " [Output to ~a/index.html]\n" fn))
             (unless (directory-exists? fn)
               (make-directory fn))
             (parameterize ([current-subdirectory (file-name-from-path fn)]
                            [current-top-part d])
               ;; install files for each directory
               (install-extra-files ds)
               (let ([fn (build-path fn "index.html")])
                 (with-output-to-file/clean
                  fn
                  (lambda () (render-one d ri fn))))))
           ds
           fns))

    (define/override (nearly-top? d ri top)
      (eq? top (collected-info-parent (part-collected-info d ri))))

    (define/override (get-onthispage-label)
      `((div ([class "tocsubtitle"]) "On this page:")))

    (define/override (toc-wrap p)
      (list p))

    (inherit render-table
             render-paragraph
             extract-version)

    (define/override (render-part d ri)
      (parameterize ([current-version (extract-version d)])
        (let ([number (collected-info-number (part-collected-info d ri))])
          (if (and (on-separate-page-ok)
                   (part-whole-page? d ri)
                   (not (eq? d (current-top-part))))
            ;; Put the actual content in a new file:
            (let* ([filename (derive-filename d #f ri (part-depth d ri))]
                   [full-path (build-path (path-only (current-output-file))
                                          filename)])
              (parameterize ([on-separate-page-ok #f]
                             [current-subdirectory (let ([p (path-only filename)])
                                                     (if p
                                                         (build-path (current-subdirectory) p)
                                                         (current-subdirectory)))])
                (with-output-to-file/clean
                 full-path
                 (lambda () (render-one-part d ri full-path number)))
                null))
            (parameterize ([on-separate-page-ok #t])
              ;; Normal section render
              (super render-part d ri))))))

    (super-new)))

;; ----------------------------------------
;; utils

(define (explode p) (explode-path p))

(define in-plt?
  (let ([roots (map explode (filter values (list (find-doc-dir) (find-collects-dir))))])
    (lambda (path)
      (for/or ([root (in-list roots)])
        (let loop ([path  path] [root root])
          (or (null? root)
              (and (pair? path)
                   (equal? (car path) (car root))
                   (loop (cdr path) (cdr root)))))))))

(define (from-root p d)
  (define c-p (simplify-path (path->complete-path p)))
  (define e-p (explode c-p))
  (define e-d (and d (explode (simplify-path (path->complete-path d)))))
  (define p-in? (in-plt? e-p))
  (define d-in? (and d (in-plt? e-d)))
  (define (normalize p) (normal-case-path p))
  use an absolute link if the link is from outside the plt tree
  ;; going in (or if d is #f)
  (if (not (and d (cond
                    [(equal? p-in? d-in?) #t]
                    [d-in?
                     #f
                     ;; This sanity check can be useful, but it doesn't work
                     ;; with layered installations and 'doc-search-dirs
                     ;; configuration
                     #;
                     (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))))

 note: file-size can be bigger than the string, but
 that's fine.
 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
  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.)
 combine a 'class attribute from both `cl' and `al'
 appears on every page
 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.
 delete file on breaks, too
 ----------------------------------------
  main mixin
 `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.
 ----------------------------------------
 ----------------------------------------
 for consistency with 'part info
 ----------------------------------------
 Called externally; not used internally
 Called externally; not used internally
 don't resolve indirect link
 ----------------------------------------
!!! need to use this
 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`:
 we have no toc, so use just the current part
 note: might be empty
 next-to-last?
 no links -- the code constructs links where needed
 toc-wrap determines if we get the toc or just the title !!!
 no section is nearly the top
 don't include the section if it's in the TOC
 get internal targets:
 Note: path is looked up and installed again below
 topmost part doesn't count as toc, since it
 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))))
 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.)
 need nbsp to make the navset bg visible
 don't show empty version:
 show version:
 Wrap each table with <p>, except for a trailing table
  when `special-last?' is #t
 short-cut for common case
 also a short-cut
 Try to extract file size:
 If the section number is empty, don't generate an
 empty link:
 Redirected to search:
 Normal link:
 Add padding for a bounding-box conversion reply:
 Descent and padding:
 Most browsers wrap after a hyphen. The one that
 strange things with it.
 ' and ` & lang ; ' in HTML 4 or 5 .
 Happened because of the thread:
   <-lang.org/users/archive/2008-June/025126.html>

 Do we still need this?  See test page at <>.
 
 More background:





 SINGLE LEFT-POINTING ANGLE QUOTATION MARK
 SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
 ----------------------------------------
 ----------------------------------------
 multi-file output
 last-ditch effort to make up a unique name:
 install files for each directory
 Put the actual content in a new file:
 Normal section render
 ----------------------------------------
 utils
 going in (or if d is #f)
 This sanity check can be useful, but it doesn't work
 with layered installations and 'doc-search-dirs
 configuration

#lang racket/base
(require "core.rkt"
         "private/render-utils.rkt"
         "html-properties.rkt"
         "private/literal-anchor.rkt"
         racket/class
         racket/path
         racket/file
         racket/port
         racket/list
         racket/string
         file/convertible
         mzlib/runtime-path
         setup/main-doc
         setup/collects
         setup/dirs
         net/url
         net/uri-codec
         net/base64
         racket/serialize
         racket/draw/gif
         pkg/path
         (prefix-in xml: xml/xml)
         (for-syntax racket/base)
         "search.rkt"
         (except-in "base.rkt" url))
(provide render-mixin
         render-multi-mixin)

(define (number->decimal-string s)
  (number->string (if (integer? s) s (exact->inexact s))))

(define as-literal
  (let ([loc (xml:make-location 0 0 0)])
    (lambda strings (xml:make-cdata loc loc (string-append* strings)))))
(define (ref-style path)
  `(link ([rel "stylesheet"] [type "text/css"] [href ,path] [title "default"])))
(define (inlined-style . body)
  `(style ([type "text/css"])
     ,(apply as-literal
             `("\n"
               ,@(map (lambda (x) (if (string? x) x (format "~a" x))) body)
               "\n"))))
(define (ref-script path)
  `(script ([type "text/javascript"] [src ,path])))
(define (inlined-script . body)
  `(script ([type "text/javascript"])
     ,(apply as-literal
             `("\n"
               ,@(map (lambda (x) (if (string? x) x (format "~a" x))) body)
               "\n"))))

(define-runtime-path scribble-css "scribble.css")
(define-runtime-path scribble-style-css "scribble-style.css")
(define-runtime-path scribble-prefix-html "scribble-prefix.html")
(define-runtime-path scribble-js  "scribble-common.js")
  utilities for render - one - part
(define-values (scribble-css-contents scribble-js-contents)
  (let* ([read-file
          (lambda (file)
            (with-input-from-file file
              (lambda ()
                (read-string (file-size file)))))]
         [adjust-rel
          (lambda (depth p)
            (if (and (relative-path? p)
                     (positive? depth))
                (let loop ([d depth] [p p])
                  (if (zero? d)
                      p
                      (loop (sub1 d) (string-append "../" p))))
                p))]
         [file-getter
          (lambda (default-file make-inline make-ref)
            (let ([c #f])
              (lambda (file path depth)
                (cond [(bytes? file)
                       (make-inline (bytes->string/utf-8 file))]
                      [(url? file)
                       (make-ref (url->string* file))]
                      [(not (eq? 'inline path))
                       (make-ref (adjust-rel
                                  depth
                                  (or path (let-values ([(base name dir?)
                                                         (split-path file)])
                                             (path->string name)))))]
                      [(or (not file) (equal? file default-file))
                       (unless c
                         (set! c (make-inline (read-file default-file))))
                       c]
                      [else (make-inline (read-file file))]))))])
    (values (file-getter scribble-css inlined-style  ref-style)
            (file-getter scribble-js  inlined-script ref-script))))

(define (lookup-path path mapping)
  (ormap (lambda (p)
           (and (equal? (car p) path)
                (cdr p)))
         mapping))

(define current-subdirectory (make-parameter #f))
(define current-output-file (make-parameter #f))
(define current-top-part (make-parameter #f))
(define on-separate-page-ok (make-parameter #t))
(define collecting-sub (make-parameter 0))
(define collecting-whole-page (make-parameter #t))
(define current-no-links (make-parameter #f))
(define extra-breaking? (make-parameter #f))
(define current-version (make-parameter (version)))
(define current-part-files (make-parameter #f))
(define current-render-convertible-requests (make-parameter '(png@2x-bytes png-bytes svg-bytes gif-bytes)))

(define (url->string* u)
  (parameterize ([current-url-encode-mode 'unreserved])
    (url->string u)))

   allowed as - is in URI components ) by using " ~ " followed by a hex
(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))))

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

  (let ([emptylabel "...search manuals..."])
    `(form ([class "searchform"])
       (input
        ([class "searchbox"]
         [id "searchbox"]
         [type "text"]
         [tabindex "1"]
         [placeholder ,emptylabel]
         [title "Enter a search string to search the manuals"]
         [onkeypress ,(format "return DoSearchKey(event, this, ~s, ~s);"
                              (version) top-path)])))))
(define search-box (make-search-box "../"))
(define top-search-box (make-search-box ""))

(define (part-tags/nonempty p)
  (define l (part-tags p))
  (if (null? l)
      (list `(part "???"))
      l))

(define (part-parent d ri)
  (collected-info-parent (part-collected-info d ri)))

(define (with-output-to-file/clean fn thunk)
                   (lambda (exn)
                     (delete-file fn)
                     (raise exn))])
    (with-output-to-file fn #:exists 'replace thunk)))


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

    (define/private (install-file/as-url fn [content #f])
      (define p (install-file fn content))
      (if (relative-path? p)
          (relative-path->relative-url-string p)
          (url->string* (path->url (path->complete-path p)))))


    (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))
                              (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)
      (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])
      (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))
         (resolve-content (element-content i) d ri)]
        [else
         (super resolve-content i d ri)]))


      (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"
                   (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]
                [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))
          (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?)
                                 (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)
        (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
              `((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  would be collapsed , then
                             (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*
                  (if (or (nearly-top? d) 
                          (part-style? d 'toc-hidden))
                      null 
                      (list (vector d prefixes d)))
                  (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)))
          (define scribble-css-path
            (or (lookup-path scribble-css alt-paths) 
                (install-file/as-url scribble-css)))
          (define script-file-path
            (or (lookup-path script-file alt-paths) 
                (install-file/as-url 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
                                           scribble-css-path
                                           dir-depth)
                   ,@(map (lambda (style-file)
                            (if (or (bytes? style-file) (url? style-file))
                                (scribble-css-contents style-file #f dir-depth)
                                (let ([p (or (lookup-path style-file alt-paths)
                                             (install-file/as-url 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
                                          script-file-path
                                          dir-depth)
                   ,@(map (lambda (script-file)
                            (if (or (bytes? script-file) (url? script-file))
                                (scribble-js-contents script-file #f dir-depth)
                                (let ([p (or (lookup-path script-file alt-paths)
                                             (install-file/as-url script-file))])
                                  (scribble-js-contents script-file p dir-depth))))
                          (append
                           (extract js-addition? js-addition-path)
                           (extract js-style-addition? js-style-addition-path)
                           (reverse extra-script-files)))
                   ,(xml:comment "[if IE 6]><style type=\"text/css\">.SIEHidden { overflow: hidden; }</style><![endif]")
                   ,@(extract head-addition? head-addition-xexpr)
                   ,@(for/list ([p (style-properties (part-style d))]
                                #:when (head-extra? p))
                       (head-extra-xexpr p)))
                 (body ([id ,(or (extract-part-body-id d ri)
                                 "scribble-racket-lang-org")])
                   ,@(if (part-style? d 'no-toc+aux)
                         null
                         (render-toc-view d ri))
                   (div ([class "maincolumn"])
                     (div ([class "main"])
                       ,@(parameterize ([current-version (extract-version d)])
                           (render-version d ri))
                       ,@(navigation d ri #t)
                       ,@(render-part d ri)
                       ,@(navigation d ri #f)))
                   (div ([id "contextindicator"]) nbsp))))))))

    (define (toc-part? d ri)
      (and (part-style? d 'toc)
           (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 tocset-toggle
        (make-element "tocsettoggle"
                      (list
                       sep-element
                       (make-element
                        (make-style #f (list
                                        (make-target-url "javascript:void(0);")
                                        (make-attributes
                                         '([title . "show/hide table of contents"]
                                           [onclick . "TocsetToggle();"]))))
                        "contents"))))
      (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))
              tocset-toggle
              )))
      (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)]
                   [(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")])
      (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 "")
            null
            `((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?)
      (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
        [(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
                      (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 (install-file/as-url src)])
             `((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)])
                                 (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))
                         (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
                         (dest->url dest)])]
                     ,@(attribs (if (or indirect-link?
                                        (and ext-id external-tag-path))
                                    '([class "Sq"])
                                    null))
                     [data-pltdoc "x"])
                    ,@(if (empty-content? (element-content e))
                          (cond
                            [number-link? (format-number (dest-number dest) '(""))]
                            [else
                             (render-content (strip-aux (dest-title dest)) part ri)])
                          (render-content (element-content e) part ri))))
               (begin
                 (when #f
                   (eprintf "Undefined link: ~s\n"
                            (tag-key (link-element-tag e) ri)))
                 `((font ([class "badlink"])
                     ,@(if (empty-content? (element-content e))
                         `(,(format "~s" (tag-key (link-element-tag e) ri)))
                         (render-plain-content e part ri))))))))]
        [else 
         (render-plain-content e part ri)]))
    
    (define/private (render-as-convertible e requests)
      (for/or ([request (in-list requests)])
        (cond
          [(case request
             [(png-bytes)
              (or (convert e 'png-bytes+bounds8)
                  (convert e 'png-bytes+bounds)
                  (convert e 'png-bytes))]
             [(png@2x-bytes)
              (or (convert e 'png@2x-bytes+bounds8)
                  (convert e 'png@2x-bytes+bounds)
                  (convert e 'png@2x-bytes))]
             [else #f])
           => 
           (lambda (cvt)
             (let* ([bstr (if (list? cvt) (first cvt) cvt)]
                    [w (if (list? cvt)
                           (list-ref cvt 1)
                           (integer-bytes->integer (subbytes bstr 16 20) #f #t))]
                    [h (if (list? cvt)
                           (list-ref cvt 2)
                           (integer-bytes->integer (subbytes bstr 20 24) #f #t))]
                    [scale (lambda (v)
                             (if (and (not (list? cvt))
                                      (equal? request 'png@2x-bytes))
                                 (/ v 2.0)
                                 v))])
               (list
                (add-padding
                 cvt
                 `(img ([src ,(install-file/as-url "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/as-url "pict.svg" bstr)]
                       [type "image/svg+xml"]))))))]
          [(and (equal? request 'gif-bytes) (convert e 'gif-bytes))
           =>
           (lambda (gif-bytes)
             (define gif-src (install-file/as-url "pict.gif" gif-bytes))

  GIFs store their width and height in the first 4 bytes of the logical screen
  descriptor , which comes after the 6 - byte long header block . The width and height are
  each represented by 2 - byte wide little - endian unsigned fields .
             (define width (+ (bytes-ref gif-bytes 6) (* (bytes-ref gif-bytes 7) 256)))
             (define height (+ (bytes-ref gif-bytes 8) (* (bytes-ref gif-bytes 9) 256)))

             (define image-tag
               `(img ([src ,gif-src]
                      [type "image/gif"]
                      [width ,(number->decimal-string width)]
                      [height ,(number->decimal-string height)])))
             (list image-tag))]
          [else #f])))

    (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
        (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/as-url link-resource)])
                       null)
                   attribs)
                 ,@content))))))

    (define/private (element-style->attribs name style [extras null])
      (combine-class
       (cond
        [(symbol? name)
         (case name
           [(emph) '([class "emph"])]
           [(italic) '([style "font-style: italic"])]
           [(bold) '([style "font-weight: bold"])]
           [(tt) '([class "stt"])]
           [(roman) '([class "sroman"])]
           [(url) '([class "url"])]
           [(no-break) '([class "nobreak"])]
           [(sf) '([class "ssansserif"])]
           [(superscript) '([style "vertical-align: super; font-size: 80%"])]
           [(subscript) '([style "vertical-align: sub; font-size: 80%"])]
           [(smaller) '([class "Smaller"])]
           [(larger) '([class "Larger"])]
           [(hspace) '([class "hspace"])]
           [(newline) '()]
           [else (error 'html-render "unrecognized style symbol: ~e" name)])]
        [(string? name) (if style null `([class ,name]))]
        [else null])
       (if style
           (style->attribs style extras)
           (if (pair? extras)
               (style->attribs (make-style #f null) extras)
               null))))

    (define/override (render-table t part ri starting-item?)
      (define (make-row flows column-styles)
        `(tr
          ,@(let loop ([ds flows]
                       [column-styles column-styles]
                       [first? #t])
              (cond
               [(null? ds) null]
               [(eq? (car ds) 'cont)
                (loop (cdr ds) (cdr column-styles) first?)]
               [else
                (let ([d (car ds)] [column-style (car column-styles)])
                  (cons
                   `(td (,@(cond
                            [(not column-style) null]
                            [(memq 'right (style-properties column-style)) '([align "right"])]
                            [(memq 'left (style-properties column-style)) '([align "left"])]
                            [(memq 'center (style-properties column-style)) '([align "center"])]
                            [else null])
                         ,@(cond
                            [(not column-style) null]
                            [(memq 'top (style-properties column-style)) '([valign "top"])]
                            [(memq 'baseline (style-properties column-style)) '([valign "baseline"])]
                            [(memq 'vcenter (style-properties column-style)) '([valign "center"])]
                            [(memq 'bottom (style-properties column-style)) '([valign "bottom"])]
                            [else null])
                         ,@(if (and column-style
                                    (string? (style-name column-style)))
                               `([class ,(style-name column-style)])
                               null)
                         ,@(if (and column-style
                                    (pair? (style-properties column-style)))
                               (style->attribs (make-style
                                                #f
                                                (filter (lambda (a)
                                                          (or (attributes? a)
                                                              (color-property? a)
                                                              (background-color-property? a)))
                                                        (style-properties column-style)))
                                               (let ([ps (style-properties column-style)])
                                                 (cond
                                                  [(memq 'border ps)
                                                   `([style "border: 1px solid black;"])]
                                                  [else
                                                   (define (check sym sfx)
                                                     (if (memq sym ps)
                                                         `([style ,(format "border-~a: 1px solid black;" sfx)])
                                                         null))
                                                   (append
                                                    (check 'top-border 'top)
                                                    (check 'bottom-border 'bottom)
                                                    (check 'left-border 'left)
                                                    (check 'right-border 'right))])))
                               null)
                         ,@(if (and (pair? (cdr ds))
                                    (eq? 'cont (cadr ds)))
                               `([colspan
                                  ,(number->string
                                    (let loop ([n 2] [ds (cddr ds)])
                                      (cond [(null? ds) n]
                                            [(eq? 'cont (car ds))
                                             (loop (+ n 1) (cdr ds))]
                                            [else n])))])
                               null))
                        ,@(if (and (paragraph? d)
                                   (memq 'omitable (style-properties (paragraph-style d))))
                              (render-content (paragraph-content d) part ri)
                              (render-block d part ri #f)))
                   (loop (cdr ds) (cdr column-styles) #f)))]))))
      (define cell-styless (extract-table-cell-styles t))
      `((table ([cellspacing "0"]
                [cellpadding "0"]
                ,@(combine-class
                   (case (style-name (table-style t))
                     [(boxed)    '([class "boxed"])]
                     [(centered) '([align "center"])]
                     [else '()])
                   (style->attribs (table-style t)
                                   (append
                                    (if starting-item?
                                        '([style "display: inline-table; vertical-align: text-top; margin-top: 0;"])
                                        null)
                                    (if (for/or ([cell-styles (in-list cell-styless)])
                                          (for/or ([cell-style (in-list cell-styles)])
                                            (and cell-style
                                                 (let ([ps (style-properties cell-style)])
                                                   (or (memq 'border ps)
                                                       (memq 'left-border ps)
                                                       (memq 'right-border ps)
                                                       (memq 'bottom-border ps)
                                                       (memq 'top-border ps))))))
                                        `([style "border-collapse: collapse;"])
                                        '())))))
          ,@(let ([columns (ormap (lambda (p)
                                    (and (table-columns? p)
                                         (map (lambda (s)
                                                (ormap (lambda (a)
                                                         (and (column-attributes? a)
                                                              a))
                                                       (style-properties s)))
                                              (table-columns-styles p))))
                                  (style-properties (table-style t)))])
              (if (and columns (ormap values columns))
                  `((colgroup ,@(for/list ([col (in-list columns)])
                                  `(col ,(if col
                                             (map (lambda (v) (list (car v) (cdr v))) (column-attributes-assoc col))
                                             null)))))
                  null))
          ,@(if (null? (table-blockss t))
                `((tr (td)))
                (map make-row
                     (table-blockss t)
                     cell-styless)))))

    (define/override (render-nested-flow t part ri starting-item?)
      `((,(or (style->tag (nested-flow-style t)) 'blockquote)
         [,@(combine-class
             (cond
              [(eq? 'code-inset (style-name (nested-flow-style t)))
               `([class "SCodeFlow"])]
              [(eq? 'vertical-inset (style-name (nested-flow-style t)))
               `([class "SVInsetFlow"])]
              [(and (not (string? (style-name (nested-flow-style t))))
                    (not (eq? 'inset (style-name (nested-flow-style t)))))
               `([class "SubFlow"])]
              [else null])
             (style->attribs (nested-flow-style t)))]
         ,@(apply append
                  (super render-nested-flow t part ri starting-item?)))))

    (define/override (render-compound-paragraph t part ri starting-item?)
      (let ([style (compound-paragraph-style t)])
        `((,(or (style->tag style) 'p)
           ,(style->attribs style)
           ,@(super render-compound-paragraph t part ri starting-item?)))))

    (define/override (render-itemization t part ri)
      (let ([style-str (and (string? (style-name (itemization-style t)))
                            (style-name (itemization-style t)))])
        `((,(if (eq? 'ordered (style-name (itemization-style t)))
                'ol
                'ul)
           (,@(style->attribs (itemization-style t))
            ,@(if (eq? 'compact (style-name (itemization-style t)))
                  `([class "compact"])
                  '()))
           ,@(map (lambda (flow) `(li ,(if style-str
                                           `([class ,(string-append style-str "Item")])
                                           `())
                                      ,@(render-flow flow part ri #t)))
                  (itemization-blockss t))))))

    (define/override (render-other i part ri)
      (cond
        [(string? i)
         (let ([m (and (extra-breaking?)
                       (regexp-match-positions #rx"[-:/+_](?=.)|[a-z](?=[A-Z])" i))])
           (if m
             (list* (substring i 0 (cdar m))
  does n't , Firefox , pays attention to wbr .   Some
  browsers ignore wbr , but at least they do n't do
                    (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
  < wbr > encourages breaking after rather than before

  ( " Fonts with proper angle brackets " )
  HTML 4 says ( in HTMLsymbol.dtd ):
  < ! ENTITY lang      CDATA " & # 9001 ; " -- left - pointing angle bracket = bra ,
                                       U+2329 ISOtech -- >
  < !   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 <  > , dated 2012 - 10 - 12 ):
    " & lang ; " : { " codepoints " : [ 10216 ] , " characters " : " \u27E8 " } ,
    " & rang ; " : { " codepoints " : [ 10217 ] , " characters " : " \u27E9 " } ,

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


(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
                             (format "???~a" (eq-hash-code d))])))
                   "_")])
        (let ([fn (if (depth . < . directory-depth)
                      (path->string (build-path base "index.html"))
                      (format "~a.html" base))])
          (when ((string-length fn) . >= . 48)
            (error "file name too long (need a tag):" fn))
          fn)))

    (define/override (include-navigation?) #t)

    (define/override (collect ds fns fp [demand (lambda (key ci) #f)])
      (super collect 
             ds 
             (map (lambda (fn) (build-path fn "index.html")) fns)
             fp
             demand))

    (define/override (current-part-whole-page? d)
      (collecting-whole-page))

    (define/override (start-collect ds fns ci)
      (parameterize ([current-part-files (make-hash)])
        (for-each (lambda (d fn)
                    (check-duplicate-filename fn)
                    (parameterize ([collecting-sub
                                    (if (part-style? d 'non-toc)
                                        1
                                        0)])
                      (super start-collect (list d) (list fn) ci)))
                  ds
                  fns)))

    (define/private (check-duplicate-filename orig-s)
      (let ([s (string-downcase (path->string orig-s))])
        (when (hash-ref (current-part-files) s #f)
          (error 'htmls-render "multiple parts have the same filename (modulo case): ~e"
                 orig-s))
        (hash-set! (current-part-files) s #t)))

    (define/override (collect-part d parent ci number sub-init-number sub-init-numberers)
      (let ([prev-sub (collecting-sub)])
        (parameterize ([collecting-sub (if (part-style? d 'toc)
                                           1 
                                           (add1 prev-sub))]
                       [collecting-whole-page (prev-sub . <= . 1)])
          (if (and (current-part-whole-page? d)
                   (not (eq? d (current-top-part))))
              (let* ([filename (derive-filename d ci #f (length number))]
                     [full-filename (build-path (path-only (current-output-file))
                                                filename)])
                (make-directory* (path-only full-filename))
                (check-duplicate-filename full-filename)
                (parameterize ([current-output-file full-filename])
                  (super collect-part d parent ci number sub-init-number sub-init-numberers)))
              (super collect-part d parent ci number sub-init-number sub-init-numberers)))))

    (define/override (render-top ds fns ri)
      (map (lambda (d fn)
             (when (report-output?)
               (printf " [Output to ~a/index.html]\n" fn))
             (unless (directory-exists? fn)
               (make-directory fn))
             (parameterize ([current-subdirectory (file-name-from-path fn)]
                            [current-top-part d])
               (install-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))))
            (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])
              (super render-part d ri))))))

    (super-new)))


(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
  (if (not (and d (cond
                    [(equal? p-in? d-in?) #t]
                    [d-in?
                     #f
                     (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))))
