(module html-render mzscheme
  (require "struct.ss"
           (lib "class.ss")
           (lib "file.ss")
           (lib "list.ss")
           (lib "runtime-path.ss")
           (prefix xml: (lib "xml.ss" "xml")))
  (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 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))

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

  (define (render-mixin %)
    (class %
      (inherit render-content
               render-flow-element
               collect-part
               install-file
               get-dest-directory
               format-number
               strip-aux
               lookup)

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

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

      (define/override (collect ds fns)
        (let ([ht (make-hash-table 'equal)])
          (map (lambda (d fn)
                 (parameterize ([current-output-file fn])
                   (collect-part d #f ht null)))
               ds
               fns)
          ht))

      (define/public (part-whole-page? d)
        #f)

      (define/override (collect-part-tag d ht number)
        (hash-table-put! ht 
                         `(part ,(part-tag d)) 
                         (list (current-output-file)
                               (part-title-content d)
                               (part-whole-page? d))))

      (define/override (collect-target-element i ht)
        (hash-table-put! ht 
                         (target-element-tag i)
                         (list (current-output-file) #f #f)))

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

      (define/public (render-toc-view d ht)
        (let-values ([(top mine)
                      (let loop ([d d][mine d])
                        (let ([p (collected-info-parent (part-collected-info d))])
                          (if p
                              (loop p d)
                              (values d mine))))])
          `((div ((class "tocview"))
                 (div ((class "tocviewtitle"))
                      (a ((href "index.html")
                          (class "tocviewlink"))
                         ,@(render-content (part-title-content top) d ht)))
                 (div nbsp)
                 (div
                  ((class "tocviewlist"))
                  ,@(map (lambda (p)
                           `(div
                             ((class "tocviewitem"))
                             (a ((href ,(let ([dest (lookup p ht `(part ,(part-tag p)))])
                                          (format "~a~a~a" 
                                                  (from-root (car dest)
                                                             (get-dest-directory))
                                                  (if (caddr dest)
                                                      ""
                                                      "#")
                                                  (if (caddr dest)
                                                      ""
                                                      `(part ,(part-tag p))))))
                                 (class ,(if (eq? p mine)
                                             "tocviewselflink"
                                             "tocviewlink")))
                                ,@(format-number (collected-info-number (part-collected-info p))
                                                 '((tt nbsp)))
                                ,@(render-content (part-title-content p) d ht))))
                         (part-parts top)))))))

      (define/public (render-one-part d ht fn number)
        (parameterize ([current-output-file fn])
          (let ([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 ht)))
                                     null))
                             (link ((rel "stylesheet")
                                    (type "text/css")
                                    (href "scribble.css")
                                    (title "default"))))
                            (body ,@(render-toc-view d ht)
                                  (div ((class "main")) ,@(render-part d ht))))])
            (install-file scribble-css)
            (xml:write-xml/content (xml:xexpr->xml xpr)))))

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

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

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

      (define/override (render-flow p part ht)
        (render-flow* p part ht #t))

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

      (define/override (render-element e part ht)
        (cond
         [(target-element? e)
          `((a ((name ,(target-element-tag e))))
            ,@(render-plain-element e part ht))]
         [(and (link-element? e)
               (not (current-no-links)))
          (parameterize ([current-no-links #t])
            (let ([dest (lookup part ht (link-element-tag e))])
              (if dest
                  `((a ((href ,(format "~a~a~a" 
                                       (from-root (car dest)
                                                  (get-dest-directory))
                                       (if (caddr dest)
                                           ""
                                           "#")
                                       (if (caddr dest)
                                           ""
                                           (link-element-tag e))))
                        ,@(if (string? (element-style e))
                              `((class ,(element-style e)))
                              null))
                       ,@(if (null? (element-content e))
                             (render-content (strip-aux (cadr dest)) part ht)
                             (render-content (element-content e) part ht))))
                  (begin (fprintf (current-error-port) "Undefined link: ~s~n" (link-element-tag e)) ; XXX Add source info
                         `((font ((class "badlink")) 
                                 ,@(if (null? (element-content e))
                                       `(,(format "~s" (link-element-tag e)))
                                       (render-plain-element e part ht))))))))]
         [else (render-plain-element e part ht)]))

      (define/private (render-plain-element e part ht)
        (let ([style (and (element? e)
                          (element-style e))])
          (cond
           [(symbol? style)
            (case style
              [(italic) `((i ,@(super render-element e part ht)))]
              [(bold) `((b ,@(super render-element e part ht)))]
              [(tt) `((tt ,@(super render-element e part ht)))]
              [(sf) `((b (font ([size "-1"][face "Helvetica"]) ,@(super render-element e part ht))))]
              [(subscript) `((sub ,@(super render-element e part ht)))]
              [(superscript) `((sup ,@(super render-element e part ht)))]
              [(hspace) `((span ([class "hspace"])
                                ,@(let ([str (content->string (element-content e))])
                                    (map (lambda (c) 'nbsp) (string->list str)))))]
              [else (error 'html-render "unrecognized style symbol: ~e" style)])]
           [(string? style) 
            `((span ([class ,style]) ,@(super render-element e part ht)))]
           [(target-url? style)
            (if (current-no-links)
                (super render-element e part ht)
                (parameterize ([current-no-links #t])
                  `((a ((href ,(target-url-addr style))) ,@(super render-element e part ht)))))]
           [(image-file? style) `((img ((src ,(install-file (image-file-path style))))))]
           [else (super render-element e part ht)])))

      (define/override (render-table t part ht)
        `((table ((cellspacing "0") 
                  ,@(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)
                          `(tr ,@(map (lambda (d a va)
                                        `(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"))]))
                                             ,@(render-flow d part ht)))
                                      flows
                                      (cdr (or (and (list? (table-style t))
                                                    (assoc 'alignment (or (table-style t) null)))
                                               (cons #f (map (lambda (x) #f) flows))))
                                      (cdr (or (and (list? (table-style t))
                                                    (assoc 'valignment (or (table-style t) null)))
                                               (cons #f (map (lambda (x) #f) flows)))))))
                        (table-flowss t)))))

      (define/override (render-blockquote t part ht)
        `((blockquote ,@(if (string? (blockquote-style t))
                            `(((class ,(blockquote-style t))))
                            null)
                      ,@(apply append
                               (map (lambda (i)
                                      (render-flow-element i part ht))
                                    (blockquote-paragraphs t))))))

      (define/override (render-itemization t part ht)
        `((ul
           ,@(map (lambda (flow)
                    `(li ,@(render-flow flow part ht)))
                  (itemization-flows t)))))

      (define/override (render-other i part ht)
        (cond
         [(string? i) (list i)]
         [(eq? i 'mdash) `(" " ndash " ")]
         [(symbol? i) (list i)]
         [else (list (format "~s" i))]))
      
      ;; ----------------------------------------

      (super-new)))

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

  (define (render-multi-mixin %)
    (class %
      (inherit render-one
               render-one-part
               render-content)

      (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/private (derive-filename d ht)
        (let ([fn (format "~a.html" (regexp-replace*
                                     "[^-a-zA-Z0-9_=]"
                                     (or (format "~a" (part-tag d))
                                         (content->string (part-title-content d)
                                                          this d ht))
                                     "_"))])
          (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 (part-whole-page? d)
        ((collecting-sub) . <= . 2))

      (define/private (toc-part? d)
        (and (styled-part? d)
             (eq? 'toc (styled-part-style d))))

      (define/override (collect-part d parent ht 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 ht)])
                  (parameterize ([current-output-file (build-path (path-only (current-output-file))
                                                                  filename)])
                    (super collect-part d parent ht number)))
                (super collect-part d parent ht number)))))
      
      (define/override (render ds fns ht)
        (map (lambda (d fn)
               (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
                     (lambda ()
                       (render-one d ht fn))
                     'truncate/replace))))
             ds
             fns))

      (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)))
      
      (inherit render-table)

      (define/private (find-siblings d)
        (let ([parent (collected-info-parent (part-collected-info d))])
          (let loop ([l (if parent
                            (part-parts parent)
                            (if (null? (part-parts d))
                                (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/private (part-parent d)
        (collected-info-parent (part-collected-info d)))
        
      (define/private (navigation d ht)
        (let ([parent (part-parent d)])
          (let*-values ([(prev next) (find-siblings d)]
                        [(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)])
                                    next)]
                                 [else next])]
                        [(index) (let loop ([d d])
                                   (let ([p (part-parent d)])
                                     (if p
                                         (loop p)
                                         (let ([subs (part-parts d)])
                                           (and (pair? subs)
                                                (let ([d (car (last-pair subs))])
                                                  (and (equal? '("Index") (part-title-content d))
                                                       d)))))))])
            `(,@(render-table (make-table
                               'at-left
                               (list
                                (cons
                                 (make-flow
                                  (list
                                   (make-paragraph
                                    (list
                                     (make-element
                                      (if parent
                                          (make-target-url "index.html")
                                          "nonavigation")
                                      contents-content)))))
                                 (if index
                                     (list
                                      (make-flow
                                       (list
                                        (make-paragraph
                                         (list
                                          'nbsp
                                          (if (eq? d index)
                                              (make-element
                                               "nonavigation"
                                               index-content)
                                              (make-link-element
                                               #f
                                               index-content
                                               `(part ,(part-tag index)))))))))
                                     null))))
                              d ht)
              ,@(render-table (make-table
                               'at-right
                               (list 
                                (list 
                                 (make-flow
                                  (list
                                   (make-paragraph
                                    (list
                                     (make-element
                                      (if parent
                                          (make-target-url (if prev
                                                               (derive-filename prev ht)
                                                               "index.html"))
                                          "nonavigation")
                                      prev-content)
                                     sep-element
                                     (make-element
                                      (if parent
                                          (make-target-url 
                                           (if (toc-part? parent)
                                               (derive-filename parent ht)
                                               "index.html"))
                                          "nonavigation")
                                      up-content)
                                     sep-element
                                     (make-element
                                      (if next
                                          (make-target-url (derive-filename next ht))
                                          "nonavigation")
                                      next-content))))))))
                              d
                              ht)))))

      (define/override (render-part d ht)
        (let ([number (collected-info-number (part-collected-info d))])
          (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 ht)]
                   [full-path (build-path (path-only (current-output-file))
                                          filename)])
              (parameterize ([on-separate-page #t])
                (with-output-to-file full-path
                  (lambda ()
                    (render-one-part d ht full-path number))
                  'truncate/replace)
                null))]
           [else
            (let ([sep? (on-separate-page)])
              (parameterize ([next-separate-page (toc-part? d)]
                             [on-separate-page #f])
                (if sep?
                    ;; Navigation bars;
                    `(,@(navigation d ht)
                      (p nbsp)
                      ,@(super render-part d ht)
                      (p nbsp)
                      ,@(navigation d ht)
                      (p nbsp))
                    ;; Normal section render
                    (super render-part d ht))))])))

      (super-new)))

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

  (define (from-root p d)
    (if d
        (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))])))
        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))))))))