(module html-render scheme/base
  (require "struct.ss"
           scheme/class
           scheme/path
           scheme/file
           mzlib/runtime-path
           setup/main-doc
           setup/main-collects
           mzlib/list
	   net/url
           scheme/serialize
           (prefix-in xml: xml/xml)
           (for-syntax scheme/base))
  (provide render-mixin
           render-multi-mixin)

  (xml:empty-tag-shorthand xml:html-empty-tags)

  (define-runtime-path scribble-css "scribble.css")

  (define current-subdirectory (make-parameter #f))
  (define current-output-file (make-parameter #f))
  (define current-top-part (make-parameter #f))
  (define on-separate-page (make-parameter #t))
  (define next-separate-page (make-parameter #f))
  (define collecting-sub (make-parameter 0))
  (define current-no-links (make-parameter #f))
  (define extra-breaking? (make-parameter #f))
  (define current-version (make-parameter (version)))

  (define (path->relative p)
    (let ([p (path->main-doc-relative p)])
      (if (path? p)
          (path->main-collects-relative p)
          p)))

  (define (relative->path p)
    (let ([p (main-doc-relative->path p)])
      (if (path? p)
          p
          (main-collects-relative->path p))))

  (define (toc-part? d)
    (part-style? d 'toc))

  ;; HTML anchors are case-insenstive. To make them
  ;;  distinct, add a "." in front of capital letters.
  ;;  Also clean up characters that give browers trouble
  ;;  (i.e., the ones that are not allowed as-in in URI
  ;;  codecs) by using "~" followed by a hex encoding.
  (define (anchor-name v)
    (if (literal-anchor? v)
        (literal-anchor-string v)
        (let loop ([s (format "~a" v)])
          (cond
           [(regexp-match-positions #rx"[A-Z.]" s)
            => (lambda (m)
                 (string-append
                  (loop (substring s 0 (caar m)))
                  "."
                  (substring s (caar m) (cdar m))
                  (loop (substring s (cdar m)))))]
           [(regexp-match-positions #rx"[^-a-zA-Z0-9_!*'().]" s)
            => (lambda (m)
                 (string-append
                  (substring s 0 (caar m))
                  "~"
                  (format "~x" (char->integer (string-ref s (caar m))))
                  (loop (substring s (cdar m)))))]
           [else s]))))

  (define-serializable-struct literal-anchor (string))

  (define literal
    (let ([loc (xml:make-location 0 0 0)])
      (lambda strings (xml:make-cdata loc loc (apply string-append strings)))))
  (define (script . body)
    `(script ((type "text/javascript"))
       ,(apply literal
               `("\n"
                 ,@(map (lambda (x) (if (string? x) x (format "~a" x))) body)
                 "\n"))))

  #reader scribble/reader (begin ; easier to format

  (define search-script
    @script{
      var search_nodes = null;
      var last_search_terms = null;
      function node_to_text(node) {
        if (node.nodeType == 3) return node.nodeValue;
        var r = "";
        var children = node.childNodes;
        for (var i=0@";" i<children.length@";" i++) {
          r = r + node_to_text(children[i]);
        }
        return r;
      }
      function initialize_search() {
        var all_links = document.getElementsByTagName("a");
        search_nodes = new Array();
        for (var i=0@";" i<all_links.length@";" i++)
          if (all_links[i].className == "indexlink") {
            all_links[i].flat_text = node_to_text(all_links[i]).toLowerCase();
            search_nodes.push(all_links[i]);
          }
        var search_box = document.getElementById("search_box");
        if (location.search.length > 0) {
          var paramstrs = location.search.substring(1).split(/[@";"&]/);
          for (var i in paramstrs) {
            var param = paramstrs[i].split(/=/);
            if (param.length == 2 && param[0] == "q") {
              search_box.value = unescape(param[1]).replace(/\+/g," ");
              break;
            }
          }
        }
        if (search_box.value != "") do_search(search_box.value);
        search_box.focus();
        search_box.select();
      }
      window.onload = initialize_search;
      function do_search(terms) {
        terms = terms.toLowerCase();
        if (terms == last_search_terms) return;
        last_search_terms = terms;
        terms = terms.split(/ +/);
        var none = true;
        for (var i=0@";" i<search_nodes.length@";" i++) {
          var show = true, curtext = search_nodes[i].flat_text;
          for (var j=0@";" j<terms.length@";" j++) {
            if (terms[j] != "" && curtext.indexOf(terms[j]) < 0) {
              show = false;
              break;
            }
          }
          if (show) none = false;
          var style = search_nodes[i].style;
          var newdisp = show ? "block" : "none";
          if (newdisp != style.display) style.display = newdisp;
        }
        search_box.style.backgroundColor = none ? "#ffe0e0" : "white";
      }
      var search_timer = null;
      function delayed_search(str, event) {
        if (event && event.keyCode == 13) {
          do_search(str);
        } else {
          if (search_timer != null) {
            var t = search_timer;
            search_timer = null;
            clearTimeout(t);
          }
          search_timer = setTimeout(function(){do_search(str)@";"}, 1000);
        }
      }})

  (define search-field
    @`p{Search: @(input ((type "text") (id "search_box")
                         (onchange "delayed_search(this.value,event);")
                         (onkeyup  "delayed_search(this.value,event);")))})

  (define (search-index-box index-url) ; appears on every page
    (let ([sa string-append])
    `(input
      ((style ,(sa "font-size: 75%; margin: 0px; padding: 0px; border: 1px;"
                   " background-color: #eee; color: #888;"))
       (type "text")
       (value "...search...")
       (onkeypress ,(sa "if (event && event.keyCode==13"
                        " && this.value.indexOf(\"...search...\")<0) {"
                        " location=\"doc-index.html?q=\"+escape(this.value);"
                        " };"))
       (onfocus ,(sa "this.style.color=\"black\";"
                     " if (this.value.indexOf(\"...search...\")>=0)"
                     " this.value=\"\";"))
       (onblur ,(sa "if (this.value.match(/^ *$/)) {"
                    " this.style.color=\"#888\";"
                    " this.value=\"...search...\"; }"))))))

  )

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

  (define (render-mixin %)
    (class %
      (inherit render-content
               render-block
               collect-part
               install-file
               get-dest-directory
               format-number
               quiet-table-of-contents)

      (init-field [css-path #f]
                  [up-path #f]
                  [style-file #f])

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

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

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

      (define/override (start-collect ds fns ci)
        (map (lambda (d fn)
               (parameterize ([current-output-file fn]
                              [current-top-part d])
                 (collect-part d #f ci null)))
             ds
             fns))

      (define/public (part-whole-page? p ri)
        (let ([dest (resolve-get p ri (car (part-tags p)))])
          (dest-page? dest)))

      (define/public (current-part-whole-page? d)
        (eq? d (current-top-part)))

      (define/override (collect-part-tags d ci number)
        (for ([t (part-tags d)])
          (let ([key (generate-tag t ci)])
            (collect-put! ci key
                          (vector (and (current-output-file)
                                       (path->relative (current-output-file)))
                                  (or (part-title-content d) '("???"))
                                  (current-part-whole-page? d)
                                  key)))))

      (define/override (collect-target-element i ci)
        (let ([key (generate-tag (target-element-tag i) ci)])
          (collect-put! ci
                        key
                        (vector (path->relative (let ([p (current-output-file)])
                                                  (if (redirect-target-element? i)
                                                      (let-values ([(base name dir?) (split-path p)])
                                                        (build-path 
                                                         base
                                                         (redirect-target-element-alt-path i)))
                                                      p)))
                                #f
                                (page-target-element? i)
                                (if (redirect-target-element? i)
                                    (make-literal-anchor (redirect-target-element-alt-anchor i))
                                    key)))))

      (define (dest-path dest)
        (if (vector? dest) ; temporary
            (vector-ref dest 0)
            (list-ref dest 0)))
      (define (dest-title dest)
        (if (vector? dest)
            (vector-ref dest 1)
            (list-ref dest 1)))
      (define (dest-page? dest)
        (if (vector? dest)
            (vector-ref dest 2)
            (list-ref dest 2)))
      (define (dest-anchor dest)
        (if (vector? dest)
            (vector-ref dest 3)
            (list-ref dest 3)))
      
      ;; ----------------------------------------

      (define/public (tag->path+anchor ri tag)
        (let ([dest (resolve-get #f ri tag)])
          (if dest
              (values
               (relative->path (dest-path dest))
               (if (dest-page? dest)
                   #f
                   (anchor-name (dest-anchor dest))))
              (values #f #f))))

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

      (define/private (reveal-subparts? p)
        (part-style? p 'reveal))

      (define/public (toc-wrap table)
        null)
    
      (define/public (render-toc-view d ri)
        (let-values ([(top mine)
                      (let loop ([d d][mine d])
                        (let ([p (collected-info-parent (part-collected-info d ri))])
                          (if p
                              (loop p (if (reveal-subparts? d)
                                          mine
                                          d))
                              (values d mine))))])
          `((div ((class "tocset"))
                 ,@(let ([toc-content 
                          (map (lambda (pp)
                                 (let ([p (car pp)]
                                       [show-number? (cdr pp)])
                                   `(tr
                                     (td 
                                      ((align "right"))
                                      ,@(if show-number?
                                            (format-number (collected-info-number (part-collected-info p ri))
                                                           '((tt nbsp)))
                                            '("-" nbsp)))
                                     (td
                                      (a ((href ,(let ([dest (resolve-get p ri (car (part-tags p)))])
                                                   (format "~a~a~a" 
                                                           (from-root (relative->path (dest-path dest))
                                                                      (get-dest-directory))
                                                           (if (dest-page? dest)
                                                               ""
                                                               "#")
                                                           (if (dest-page? dest)
                                                               ""
                                                               (anchor-name (dest-anchor dest))))))
                                          (class ,(if (eq? p mine)
                                                      "tocviewselflink"
                                                      "tocviewlink")))
                                         ,@(render-content (or (part-title-content p) '("???")) d ri))))))
                               (let loop ([l (map (lambda (v) (cons v #t)) (part-parts top))])
                                 (cond
                                  [(null? l) null]
                                  [(reveal-subparts? (caar l))
                                   (cons (car l) (loop (append (map (lambda (v) (cons v #f))
                                                                    (part-parts (caar l)))
                                                               (cdr l))))]
                                  [else (cons (car l) (loop (cdr l)))])))])
                     (let* ([content (render-content
                                      (or (part-title-content top) '("???"))
                                      d ri)]
                            [content (if (null? toc-content)
                                       content
                                       `((a ((href "index.html")
                                             (class "tocviewlink"))
                                           ,@content)))])
                       `((div ((class "tocview"))
                           (div ((class "tocviewtitle")) ,@content)
                           (div nbsp)
                           ,@(if (null? toc-content)
                               '()
                               (toc-wrap
                                `(table ((class "tocviewlist") (cellspacing "0"))
                                        ,@toc-content)))))))
                 ,@(render-onthispage-contents d ri top)
                 ,@(parameterize ([extra-breaking? #t])
                     (apply append
                            (map (lambda (t)
                                   (let loop ([t t])
                                     (if (table? t)
                                         (render-table t d ri #f)
                                         (loop (delayed-block-blocks t ri)))))
                                 (filter (lambda (e)
                                           (let loop ([e e])
                                             (or (and (auxiliary-table? e)
                                                      (pair? (table-flowss e)))
                                                 (and (delayed-block? e)
                                                      (loop (delayed-block-blocks e ri))))))
                                         (flow-paragraphs (part-flow d))))))))))

      (define/public (get-onthispage-label)
        null)

      (define/public (nearly-top? d ri top)
        #f)

      (define/private (render-onthispage-contents d ri top)
        (if (ormap (lambda (p) (part-whole-page? p ri))
                   (part-parts d))
            null
            (let* ([nearly-top? (lambda (d) (nearly-top? d ri top))]
                   [ps ((if (nearly-top? d) values cdr)
                        (let flatten ([d d])
                          (apply
                           append
                           ;; don't include the section if it's in the TOC
                           (if (nearly-top? d)
                               null
                               (list d))
                           ;; get internal targets:
                           (letrec ([flow-targets
                                     (lambda (flow)
                                       (apply append (map block-targets (flow-paragraphs flow))))]
                                    [block-targets
                                     (lambda (e)
                                       (cond
                                        [(table? e) (table-targets e)]
                                        [(paragraph? e) (para-targets e)]
                                        [(itemization? e)
                                         (apply append (map flow-targets (itemization-flows e)))]
                                        [(blockquote? e)
                                         (apply append (map block-targets (blockquote-paragraphs e)))]
                                        [(delayed-block? e)
                                         null]))]
                                    [para-targets
                                     (lambda (para)
                                       (let loop ([c (paragraph-content para)])
                                         (cond
                                          [(null? c) null]
                                          [else (let ([a (car c)])
                                                  (cond
                                                   [(toc-target-element? a)
                                                    (cons a (loop (cdr c)))]
                                                   [(toc-element? a)
                                                    (cons a (loop (cdr c)))]
                                                   [(element? a)
                                                    (append (loop (element-content a))
                                                            (loop (cdr c)))]
                                                   [(delayed-element? a)
                                                    (loop (append (delayed-element-content a ri)
                                                                  (cdr c)))]
                                                   [(part-relative-element? a)
                                                    (loop (append (part-relative-element-content a ri)
                                                                  (cdr c)))]
                                                   [else
                                                    (loop (cdr c))]))])))]
                                    [table-targets
                                     (lambda (table)
                                       (apply append 
                                              (map (lambda (flows)
                                                     (apply append (map (lambda (f)
                                                                          (if (eq? f 'cont)
                                                                              null
                                                                              (flow-targets f)))
                                                                        flows)))
                                                   (table-flowss table))))])
                             (apply append (map block-targets (flow-paragraphs (part-flow d)))))
                           (map flatten (part-parts d)))))]
                   [any-parts? (ormap part? ps)])
              (if (null? ps)
                  null
                  `((div ((class "tocsub"))
                         ,@(get-onthispage-label)
                         (table
                          ((class "tocsublist")
                           (cellspacing "0"))
                          ,@(map (lambda (p)
                                   `(tr
                                     (td 
                                      ,@(if (part? p)
                                            `((span ((class "tocsublinknumber"))
                                                    ,@(format-number (collected-info-number 
                                                                      (part-collected-info p ri))
                                                                     '((tt nbsp)))))
                                            '(""))
                                      ,@(if (toc-element? p)
                                            (render-content (toc-element-toc-content p) d ri)
                                            (parameterize ([current-no-links #t]
                                                           [extra-breaking? #t])
                                              `((a ((href ,(if (part? p)
                                                               (format "#~a" (anchor-name (tag-key (car (part-tags p)) ri)))
                                                               (format "#~a" (anchor-name (tag-key (target-element-tag p) ri)))))
                                                    (class ,(if (part? p)
                                                                "tocsubseclink"
                                                                (if any-parts?
                                                                    "tocsubnonseclink"
                                                                    "tocsublink"))))
                                                   ,@(if (part? p)
                                                         (render-content (or (part-title-content p) '("???")) d ri)
                                                         (render-content (element-content p) d ri)))))))))
                                 ps))))))))

      (define/public (render-one-part d ri fn number)
        (parameterize ([current-output-file fn])
          (let* ([style-file (or style-file scribble-css)]
                 [xpr `(html ()
                         (head
                          (meta ((http-equiv "content-type")
                                 (content "text-html; charset=utf-8")))
                          ,@(let ([c (part-title-content d)])
                              (if c
                                `((title ,@(format-number number '(nbsp))
                                         ,(content->string c this d ri)))
                                 null))
                          ,(if (eq? 'inline css-path)
                             `(style ([type "text/css"])
                                "\n"
                                ,(with-input-from-file style-file
                                   (lambda ()
                                     ;; note: file-size can be bigger that the
                                     ;; string, but that's fine.
                                     (read-string (file-size style-file))))
                                "\n")
                             `(link ((rel "stylesheet")
                                      (type "text/css")
                                     (href ,(or css-path 
                                                (let-values ([(base name dir?)
                                                              (split-path style-file)])
                                                  (path->string name))))
                                     (title "default")))))
                         (body ,@(render-toc-view d ri)
                           (div ((class "maincolumn"))
                             (div ((class "main"))
                               ,@(render-version d ri)
                               ,@(navigation d ri #f)
                               ,@(render-part d ri)
                               ,@(navigation d ri #t)))))])
            (unless css-path
              (install-file style-file))
            (printf "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n")
            (xml:write-xml/content (xml:xexpr->xml xpr)))))

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

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

      (define contents-content '("contents"))
      (define index-content '("index"))
      (define prev-content '(larr " prev"))
      (define up-content '("up"))
      (define next-content '("next " rarr))
      (define no-next-content next-content)
      (define sep-element (make-element #f '(nbsp nbsp)))

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

      (define/private (navigation d ri pre-space?)
        (define parent (part-parent d ri))
        (let*-values ([(prev next) (find-siblings d ri)]
                      [(prev) (if prev
                                (let loop ([prev prev])
                                  (if (and (toc-part? prev)
                                           (pair? (part-parts prev)))
                                    (loop (car (last-pair (part-parts prev))))
                                    prev))
                                (and parent (toc-part? parent) parent))]
                      [(next) (cond
                                [(and (toc-part? d)
                                      (pair? (part-parts d)))
                                 (car (part-parts d))]
                                [(and (not next) parent (toc-part? parent))
                                 (let-values ([(prev next)
                                               (find-siblings parent ri)])
                                   next)]
                                [else next])]
                      [(index) (let loop ([d d])
                                 (let ([p (part-parent d ri)])
                                   (if p
                                     (loop p)
                                     (let ([subs (part-parts d)])
                                       (and (pair? subs)
                                            (let ([d (car (last-pair subs))])
                                              (and (part-style? d 'index)
                                                   d)))))))])
          (define (render . content)
            (render-content content d ri))
          (if (not (or prev next parent index up-path))
            null
            `(,@(if pre-space? '((p nbsp)) null)
              (div ([class "navleft"])
                ,@(render (make-element
                           (if parent
                             (make-target-url "index.html" #f)
                             "nonavigation")
                           contents-content))
                ,@(if index
                    `(nbsp
                      ,@(render (if (eq? d index)
                                  (make-element "nonavigation" index-content)
                                  (make-link-element
                                   #f index-content (car (part-tags index)))))
                      ,@(if (eq? d index)
                          null
                          `((small nbsp
                             ,(search-index-box (derive-filename index))))))
                    null))
              (div ([class "navright"])
                ,@(render
                   (make-element
                    (if parent
                      (make-target-url
                       (if prev (derive-filename prev) "index.html")
                       #f)
                      "nonavigation")
                    prev-content)
                   sep-element
                   (make-element
                    (if (or parent up-path)
                      (make-target-url
                       (if parent
                         (if (toc-part? parent)
                           (derive-filename parent)
                           "index.html")
                         up-path)
                       #f)
                      "nonavigation")
                    up-content)
                   sep-element
                   (make-element
                    (if next
                      (make-target-url (derive-filename next) #f)
                      "nonavigation")
                    next-content)))
              (p nbsp)))))

      (define/override (render-one d ri fn)
        (render-one-part d ri fn null))

      (define/public (render-version d ri)
        `((div ([class "versionbox"])
               ,@(render-content 
                  (list 
                   (make-element "version"
                                 (list "Version: "
                                       (current-version))))
                  d
                  ri))))

      (define/override (render-part d ri)
        (let ([number (collected-info-number (part-collected-info d ri))])
          `(,@(if (and (not (part-title-content d))
                       (null? number))
                  null
                  (if (part-style? d 'hidden)
                      (map (lambda (t)
                             `(a ((name ,(format "~a" (anchor-name (tag-key t ri)))))))
                           (part-tags d))
                      `((,(case (length number)
                            [(0) 'h2]
                            [(1) 'h3]
                            [(2) 'h4]
                            [else 'h5])
                         ,@(format-number number '((tt nbsp)))
                         ,@(map (lambda (t)
                                  `(a ((name ,(format "~a" (anchor-name (tag-key t ri)))))))
                                (part-tags d))
                         ,@(if (part-title-content d)
                               (render-content (part-title-content d) d ri)
                               null)))))
            ,@(render-flow* (part-flow d) d ri #f #f)
            ,@(let loop ([pos 1]
                         [secs (part-parts d)])
                (if (null? secs)
                    null
                    (append
                     (render-part (car secs) ri)
                     (loop (add1 pos) (cdr secs))))))))

      (define/private (render-flow* p part ri start-inline? special-last?)
        ;; Wrap each table with <p>, except for a trailing table
        ;;  when `special-last?' is #t
        (let loop ([f (flow-paragraphs p)][inline? start-inline?])
          (cond
           [(null? f) null]
           [(and (table? (car f)) 
                 (or (not special-last?)
                     (not (null? (cdr f)))))
            (cons `(p ,@(render-block (car f) part ri inline?))
                  (loop (cdr f) #f))]
           [else
            (append (render-block (car f) part ri inline?)
                    (loop (cdr f) #f))])))

      (define/override (render-flow p part ri start-inline?)
        (render-flow* p part ri start-inline? #t))

      (define/override (render-paragraph p part ri)
        `((p ,@(if (styled-paragraph? p)
                   `(((class ,(styled-paragraph-style p))))
                   null)
             ,@(super render-paragraph p part ri))))

      (define/override (render-element e part ri)
        (cond
         [(hover-element? e)
          `((span ((title ,(hover-element-text e))) ,@(render-plain-element e part ri)))]
         [(target-element? e)
          `((a ((name ,(format "~a" (anchor-name (tag-key (target-element-tag e) ri))))))
            ,@(render-plain-element e part ri))]
         [(and (link-element? e)
               (not (current-no-links)))
          (parameterize ([current-no-links #t])
            (let ([dest (resolve-get part ri (link-element-tag e))])
              (if dest
                  `((a ((href ,(format "~a~a~a" 
                                       (from-root (relative->path (dest-path dest))
                                                  (get-dest-directory))
                                       (if (dest-page? dest)
                                           ""
                                           "#")
                                       (if (dest-page? dest)
                                           ""
                                           (anchor-name (dest-anchor dest)))))
                        ,@(if (string? (element-style e))
                              `((class ,(element-style e)))
                              null))
                       ,@(if (null? (element-content e))
                             (render-content (strip-aux (dest-title dest)) part ri)
                             (render-content (element-content e) part ri))))
                  (begin 
                    (when #f
                      (fprintf (current-error-port) 
                               "Undefined link: ~s~n" 
                               (tag-key (link-element-tag e) ri)))
                    `((font ((class "badlink")) 
                            ,@(if (null? (element-content e))
                                  `(,(format "~s" (tag-key (link-element-tag e) ri)))
                                  (render-plain-element e part ri))))))))]
         [else (render-plain-element e part ri)]))

      (define/private (render-plain-element e part ri)
        (let ([style (and (element? e)
                          (element-style e))])
          (cond
           [(symbol? style)
            (case style
              [(italic) `((i ,@(super render-element e part ri)))]
              [(bold) `((b ,@(super render-element e part ri)))]
              [(tt) `((span ([class "stt"]) ,@(super render-element e part ri)))]
              [(no-break) `((span ([class "nobreak"]) ,@(super render-element e part ri)))]
              [(sf) `((b (font ([size "-1"][face "Helvetica"]) ,@(super render-element e part ri))))]
              [(subscript) `((sub ,@(super render-element e part ri)))]
              [(superscript) `((sup ,@(super render-element e part ri)))]
              [(hspace) `((span ([class "hspace"])
                                ,@(let ([str (content->string (element-content e))])
                                    (map (lambda (c) 'nbsp) (string->list str)))))]
              [(newline) `((br))]
              [else (error 'html-render "unrecognized style symbol: ~e" style)])]
           [(string? style) 
            `((span ([class ,style]) ,@(super render-element e part ri)))]
           [(and (pair? style)
                 (or (eq? (car style) 'bg-color)
                     (eq? (car style) 'color)))
            (unless (and (list? style)
                         (or (and (= 4 (length style))
                                  (andmap byte? (cdr style)))
                             (and (= 2 (length style))
                                  (member (cadr style)
                                          '("white" "black" "red" "green" "blue" "cyan" "magenta" "yellow")))))
              (error 'render-font "bad color style: ~e"  style))
            `((font ((style ,(format "~acolor: ~a"
                                     (if (eq? (car style) 'bg-color)
                                         "background-"
                                         "")
                                     (if (= 2 (length style))
                                         (cadr style)
                                         (apply string-append "#"
                                                (map (lambda (v) (let ([s (format "0~x" v)])
                                                                   (substring s (- (string-length s) 2))))
                                                     (cdr style)))))))
                    ,@(super render-element e part ri)))]
           [(target-url? style)
            (if (current-no-links)
                (super render-element e part ri)
                (parameterize ([current-no-links #t])
                  `((a ((href ,(let ([addr (target-url-addr style)])
                                 (if (path? addr)
                                     (from-root addr
                                                (get-dest-directory))
                                     addr)))
                        ,@(if (string? (target-url-style style))
                              `((class ,(target-url-style style)))
                              null))
                       ,@(super render-element e part ri)))))]
           [(url-anchor? style)
            `((a ((name ,(url-anchor-name style)))
                 ,@(super render-element e part ri)))]
           [(image-file? style) 
            (let* ([src (main-collects-relative->path (image-file-path style))]
                   [scale (image-file-scale style)]
                   [sz (if (= 1.0 scale)
                           null
                           ;; Try to extract file size:
                           (call-with-input-file* 
                            src
                            (lambda (in)
                              (if (regexp-try-match #px#"^\211PNG.{12}" in)
                                  (let ([w (read-bytes 4 in)]
                                        [h (read-bytes 4 in)]
                                        [to-num (lambda (s)
                                                  (number->string
                                                   (inexact->exact
                                                    (floor (* scale (integer-bytes->integer s #f #t))))))])
                                    `((width ,(to-num w))
                                      (height ,(to-num h))))
                                  null))))])
              `((img ((src ,(let ([p (install-file src)])
                              (if (path? p)
                                  (url->string (path->url p))
                                  p))))
                     ,@sz)))]
           [else (super render-element e part ri)])))

      (define/override (render-table t part ri need-inline?)
        (define index? (eq? 'index (table-style t)))
        `(,@(if index? `(,search-script ,search-field) '())
          (table ((cellspacing "0")
                  ,@(if need-inline?
                        '((style "display: inline; vertical-align: top;"))
                        null)
                  ,@(case (table-style t)
                      [(boxed)    '((class "boxed"))]
                      [(centered) '((align "center"))]
                      [(at-right) '((align "right"))]
                      [(at-left)  '((align "left"))]
                      [else null])
                  ,@(let ([a (and (list? (table-style t))
                                  (assoc 'style (table-style t)))])
                      (if (and a (string? (cadr a)))
                          `((class ,(cadr a)))
                          null))
                  ,@(if (string? (table-style t))
                        `((class ,(table-style t)))
                        null))
                 ,@(map (lambda (flows style)
                          `(tr (,@(if style
                                      `((class ,style))
                                      null))
                               ,@(let loop ([ds flows]
                                            [as (cdr (or (and (list? (table-style t))
                                                              (assoc 'alignment (or (table-style t) null)))
                                                         (cons #f (map (lambda (x) #f) flows))))]
                                            [vas
                                             (cdr (or (and (list? (table-style t))
                                                           (assoc 'valignment (or (table-style t) null)))
                                                      (cons #f (map (lambda (x) #f) flows))))])
                                   (if (null? ds)
                                       null
                                       (if (eq? (car ds) 'cont)
                                           (loop (cdr ds) (cdr as) (cdr vas))
                                           (let ([d (car ds)]
                                                 [a (car as)]
                                                 [va (car vas)])
                                             (cons
                                              `(td (,@(case a
                                                        [(#f) null]
                                                        [(right) '((align "right"))]
                                                        [(center) '((align "center"))]
                                                        [(left) '((align "left"))])
                                                    ,@(case va
                                                        [(#f) null]
                                                        [(top) '((valign "top"))]
                                                        [(baseline) '((valign "baseline"))]
                                                        [(bottom) '((valign "bottom"))])
                                                    ,@(if (and (pair? (cdr ds))
                                                               (eq? 'cont (cadr ds)))
                                                          `((colspan
                                                             ,(number->string
                                                               (let loop ([n 2]
                                                                          [ds (cddr ds)])
                                                                 (cond
                                                                  [(null? ds) n]
                                                                  [(eq? 'cont (car ds)) (loop (+ n 1) (cdr ds))]
                                                                  [else n])))))
                                                          null))
                                                   ,@(render-flow d part ri #f))
                                              (loop (cdr ds) (cdr as) (cdr vas)))))))))
                        (table-flowss t)
                        (cdr (or (and (list? (table-style t))
                                      (assoc 'row-styles (or (table-style t) null)))
                                 (cons #f (map (lambda (x) #f) (table-flowss t)))))))))

      (define/override (render-blockquote t part ri)
        `((blockquote ,@(if (string? (blockquote-style t))
                            `(((class ,(blockquote-style t))))
                            null)
                      ,@(apply append
                               (map (lambda (i)
                                      (render-block i part ri #f))
                                    (blockquote-paragraphs t))))))

      (define/override (render-itemization t part ri)
        `((ul
           ,@(if (and (styled-itemization? t)
                      (string? (styled-itemization-style t)))
                 `(((class ,(styled-itemization-style t))))
                 null)
           ,@(map (lambda (flow)
                    `(li ,@(render-flow flow part ri #t)))
                  (itemization-flows t)))))

      (define/override (render-other i part ri)
        (cond
         [(string? i)
          (let ([m (and (extra-breaking?)
                        (regexp-match-positions #rx"[-:/+]" i))])
            (if m
              (list* (substring i 0 (cdar m))
                     ;; Most browsers wrap after a hyphen. The
                     ;; one that doesn't, Firefox, pays attention
                     ;; to wbr. Some browsers ignore wbr, but
                     ;; at least they don't do strange things with it.
                     (if (equal? #\- (string-ref i (caar m)))
                       '(wbr)
                       `(span ((class "mywbr")) " "))
                     (render-other (substring i (cdar m)) part ri))
              (ascii-ize i)))]
         [(eq? i 'mdash) `(" " ndash " ")]
         [(symbol? i) (list i)]
         [else (list (format "~s" i))]))

      (define/private (ascii-ize s)
        (let ([m (regexp-match-positions #rx"[^\u01-\u7E]" s)])
          (if m
              (append (ascii-ize (substring s 0 (caar m)))
                      (list (char->integer (string-ref s (caar m))))
                      (ascii-ize (substring s (cdar m))))
              (list s))))
      
      ;; ----------------------------------------

      (super-new)))

  ;; ----------------------------------------
  ;; multi-file output 

  (define (render-multi-mixin %)
    (class %
      (inherit render-one
               render-one-part
               render-content
               part-whole-page?
               format-number)

      (inherit-field report-output?)

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

      (define/override (get-dest-directory)
        (or (build-path (or (super get-dest-directory) (current-directory))
                        (current-subdirectory))
            (super get-dest-directory)))

      (define/override (derive-filename d)
        (let ([fn (format "~a.html" (regexp-replace*
                                     "[^-a-zA-Z0-9_=]"
                                     (let ([s (cadr (car (part-tags d)))])
                                       (if (string? s)
                                           s
                                           (if (part-title-content d)
                                               (content->string (part-title-content d))
                                               ;; last-ditch effort to make up a unique name:
                                               (format "???~a" (eq-hash-code d)))))
                                     "_"))])
          (when ((string-length fn) . >= . 48)
            (error "file name too long (need a tag):" fn))
          fn))

      (define/override (collect ds fns)
        (super collect ds (map (lambda (fn)
                                 (build-path fn "index.html"))
                               fns)))

      (define/override (current-part-whole-page? d)
        ((collecting-sub) . <= . 2))

      (define/override (collect-part d parent ci number)
        (let ([prev-sub (collecting-sub)])
          (parameterize ([collecting-sub (if (toc-part? d)
                                             1
                                             (add1 prev-sub))])
            (if (= 1 prev-sub)
                (let ([filename (derive-filename d)])
                  (parameterize ([current-output-file (build-path (path-only (current-output-file))
                                                                  filename)])
                    (super collect-part d parent ci number)))
                (super collect-part d parent ci number)))))
      
      (define/override (render ds fns ri)
        (map (lambda (d fn)
               (when report-output?
                 (printf " [Output to ~a/index.html]\n" fn))
               (unless (directory-exists? fn)
                 (make-directory fn))
               (parameterize ([current-subdirectory (file-name-from-path fn)])
                 (let ([fn (build-path fn "index.html")])
                   (with-output-to-file fn
                     #:exists 'truncate/replace
                     (lambda ()
                       (render-one d ri fn))))))
             ds
             fns))

      (define/override (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)

      (define/override (render-part d ri)
        (parameterize ([current-version
                        (if (and (versioned-part? d)
                                 (versioned-part-version d))
                            (versioned-part-version d)
                            (current-version))])
          (let ([number (collected-info-number (part-collected-info d ri))])
            (cond
             [(and (not (on-separate-page))
                   (or (= 1 (length number))
                       (next-separate-page)))
              ;; Render as just a link, and put the actual 
              ;; content in a new file:
              (let* ([filename (derive-filename d)]
                     [full-path (build-path (path-only (current-output-file))
                                            filename)])
                (parameterize ([on-separate-page #t])
                  (with-output-to-file full-path
                    #:exists 'truncate/replace
                    (lambda ()
                      (render-one-part d ri full-path number)))
                  null))]
             [else
              (let ([sep? (on-separate-page)])
                (parameterize ([next-separate-page (toc-part? d)]
                               [on-separate-page #f])
                  ;; Normal section render
                  (super render-part d ri)))]))))

      (super-new)))

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

  (define (from-root p d)
    (if (not d)
      (url->string (path->url p))
      (let ([e-d (explode (path->complete-path d (current-directory)))]
            [e-p (explode (path->complete-path p (current-directory)))])
        (let loop ([e-d e-d]
                   [e-p e-p])
          (cond
            [(null? e-d)
             (let loop ([e-p e-p])
               (cond
                 [(null? e-p) "/"]
                 [(null? (cdr e-p)) (car e-p)]
                 [(eq? 'same (car e-p)) (loop (cdr e-p))]
                 [(eq? 'up (car e-p)) (string-append "../" (loop (cdr e-p)))]
                 [else (string-append (car e-p) "/" (loop (cdr e-p)))]))]
            [(equal? (car e-d) (car e-p)) (loop (cdr e-d) (cdr e-p))]
            [(eq? 'same (car e-d)) (loop (cdr e-d) e-p)]
            [(eq? 'same (car e-p)) (loop e-d (cdr e-p))]
            [else (string-append
                   (apply string-append (map (lambda (x) "../") e-d))
                   (loop null e-p))])))))

  (define (explode p)
    (reverse (let loop ([p p])
               (let-values ([(base name dir?) (split-path p)])
                 (let ([name (if base
                                 (if (path? name)
                                     (path-element->string name)
                                     name)
                                 name)])
                   (if (path? base)
                       (cons name (loop base))
                       (list name))))))))