#lang racket/base
(require "core.rkt" 
         "base-render.rkt"
         "private/render-utils.rkt"
         racket/class racket/port racket/list racket/string
         scribble/text/wrap)
(provide render-mixin)

(define current-preserve-spaces (make-parameter #f))

(define current-indent (make-parameter 0))
(define (make-indent amt)
  (+ amt (current-indent)))
(define (indent)
  (define i (current-indent))
  (unless (zero? i) (display (make-string i #\space))))
(define (indented-newline)
  (newline)
  (indent))

(define render-mixin
  (mixin (render<%>) ()

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

    (define/override (get-substitutions)
      '((#rx"---" "\U2014")
        (#rx"--" "\U2013")
        (#rx"``" "\U201C")
        (#rx"''" "\U201D")
        (#rx"'" "\U2019")))

    (inherit render-block
             format-number)

    (define/override (render-part d ht)
      (let ([number (collected-info-number (part-collected-info d ht))])
        (unless (part-style? d 'hidden)
          (let ([s (format-number number '() #t)])
            (unless (null? s)
              (printf "~a~a" 
                      (car s)
                      (if (part-title-content d)
                          " "
                          "")))
            (when (part-title-content d)
              (render-content (part-title-content d) d ht))
            (when (or (pair? number) (part-title-content d))
              (newline)
              (newline))))
        (render-flow (part-blocks d) d ht #f)
        (let loop ([pos 1]
                   [secs (part-parts d)]
                   [need-newline? (pair? (part-blocks d))])
          (unless (null? secs)
            (when need-newline? (newline))
            (render-part (car secs) ht)
            (loop (add1 pos) (cdr secs) #t)))))

    (define/override (render-flow f part ht starting-item?)
      (if (null? f)
          null
          (append*
           (render-block (car f) part ht starting-item?)
           (for/list ([p (in-list (cdr f))])
             (indented-newline)
             (render-block p part ht #f)))))

    (define/override (render-intrapara-block p part ri first? last? starting-item?)
      (unless first? (indented-newline))
      (super render-intrapara-block p part ri first? last? starting-item?))

    (define/override (render-table i part ht inline?)
      (define flowss (table-blockss i))
      (if (null? flowss)
          null
          (let* ([strs (map (lambda (flows)
                              (map (lambda (d)
                                     (if (eq? d 'cont)
                                         d
                                         (let ([o (open-output-string)])
                                           (parameterize ([current-indent 0]
                                                          [current-output-port o])
                                             (render-block d part ht #f))
                                           (regexp-split
                                            #rx"\n"
                                            (regexp-replace #rx"\n$" (get-output-string o) "")))))
                                   flows))
                            flowss)]
                 [extract-align
                  (lambda (s)
                    (define p (style-properties s))
                    (cond
                     [(member 'right p) 'right]
                     [(member 'center p) 'center]
                     [else 'left]))]
                 [alignss
                  (cond
                   [(ormap (lambda (v) (and (table-cells? v) v)) (style-properties (table-style i)))
                    => (lambda (tc)
                         (for/list ([l (in-list (table-cells-styless tc))])
                           (for/list ([s (in-list l)])
                             (extract-align s))))]
                   [(ormap (lambda (v) (and (table-columns? v) v)) (style-properties (table-style i)))
                    => (lambda (tc)
                         (make-list
                          (length flowss)
                          (for/list ([s (in-list (table-columns-styles tc))])
                            (extract-align s))))]
                   [else
                    (if (null? flowss)
                        null
                        (make-list (length flowss) (make-list (length (car flowss)) 'left)))])]
                 [extract-border
                  (lambda (s)
                    (define p (style-properties s))
                    (cond
                     [(memq 'border p) '#(#t #t #t #t)]
                     [else
                      (vector (memq 'left-border p) (memq 'right-border p)
                              (memq 'top-border p) (memq 'bottom-border p))]))]
                 [borderss
                  ;; A border is (vector left? right? top? bottom?)
                  (cond
                   [(ormap (lambda (v) (and (table-cells? v) v)) (style-properties (table-style i)))
                    => (lambda (tc)
                         (for/list ([l (in-list (table-cells-styless tc))])
                           (for/list ([s (in-list l)])
                             (extract-border s))))]
                   [(ormap (lambda (v) (and (table-columns? v) v)) (style-properties (table-style i)))
                    => (lambda (tc)
                         (make-list
                          (length flowss)
                          (for/list ([s (in-list (table-columns-styles tc))])
                            (extract-border s))))]
                   [else
                    (if (null? flowss)
                        null
                        (make-list (length flowss) (make-list (length (car flowss)) '#(#f #f #f #f))))])]
                 [border-left? (lambda (v) (vector-ref v 0))]
                 [border-right? (lambda (v) (vector-ref v 1))]
                 [border-top? (lambda (v) (vector-ref v 2))]
                 [border-bottom? (lambda (v) (vector-ref v 3))]
                 [col-borders ; has only left and right
                  (for/list ([i (in-range (length (car borderss)))])
                    (for/fold ([v '#(#f #f)]) ([borders (in-list borderss)])
                      (define v2 (list-ref borders i))
                      (vector (or (border-left? v) (border-left? v2))
                              (or (border-right? v) (border-right? v2)))))]
                 [widths (map (lambda (col)
                                (for/fold ([d 0]) ([i (in-list col)])
                                  (if (eq? i 'cont)
                                      d
                                      (apply max d (map string-length i)))))
                              (apply map list strs))]
                 [x-length (lambda (col) (if (eq? col 'cont) 0 (length col)))])

            (define (show-row-border prev-borders borders)
              (when (for/or ([prev-border (in-list prev-borders)]
                             [border (in-list borders)])
                      (or (border-bottom? prev-border)
                          (border-top? border)))
                (define-values (end-h-border? end-v-border?)
                  (for/fold ([left-border? #f]
                             [prev-border? #f])
                      ([w (in-list widths)]
                       [prev-border (in-list prev-borders)]
                       [border (in-list borders)]
                       [col-border (in-list col-borders)])
                    (define border? (or (and prev-border (border-bottom? prev-border))
                                        (border-top? border)))
                    (when (or left-border? (border-left? col-border))
                      (display (if (or prev-border? border?) "-" " ")))
                    (display (make-string w (if border? #\- #\space)))
                    (values (border-right? col-border) border?)))
                (when end-h-border?
                  (display (if end-v-border? "-" " ")))
                (newline)))

            (define-values (last-indent? last-borders)
              (for/fold ([indent? #f] [prev-borders #f]) ([row (in-list strs)]
                                                          [aligns (in-list alignss)]
                                                          [borders (in-list borderss)])
                (values
                 (let ([h (apply max 0 (map x-length row))])
                   (let ([row* (for/list ([i (in-range h)])
                                 (for/list ([col (in-list row)])
                                   (if (i . < . (x-length col))
                                       (list-ref col i)
                                       (if (eq? col 'cont)
                                           'cont
                                           ""))))])
                     (for/fold ([indent? indent?]) ([sub-row (in-list row*)]
                                                    [pos (in-naturals)])
                       (when indent? (indent))

                       (when (zero? pos)
                         (show-row-border (or prev-borders (map (lambda (b) '#(#f #f #f #f)) borders))
                                          borders))

                       (define-values (end-border? end-col-border?)
                         (for/fold ([left-border? #f] [left-col-border? #f])
                             ([col (in-list sub-row)]
                              [w (in-list widths)]
                              [align (in-list aligns)]
                              [border (in-list borders)]
                              [col-border (in-list col-borders)])
                           (when (or left-col-border? (border-left? col-border))
                             (display (if (and (or left-border? (border-left? border))
                                               (not (eq? col 'cont)))
                                          "|"
                                          " ")))
                           (let ([col (if (eq? col 'cont) "" col)])
                             (define gap (max 0 (- w (string-length col))))
                             (case align
                               [(right) (display (make-string gap #\space))]
                               [(center) (display (make-string (quotient gap 2) #\space))])
                             (display col)
                             (case align
                               [(left) (display (make-string gap #\space))]
                               [(center) (display (make-string (- gap (quotient gap 2)) #\space))]))
                           (values (border-right? border)
                                   (border-right? col-border))))
                       (when end-col-border?
                         (display (if end-border? "|" " ")))
                       (newline)
                       #t)))
                 borders)))

            (show-row-border last-borders (map (lambda (b) '#(#f #f #f #f)) last-borders))

            null)))

    (define/override (render-itemization i part ht)
      (let ([flows (itemization-blockss i)])
        (if (null? flows)
            null
            (append*
             (begin (printf "* ")
                    (parameterize ([current-indent (make-indent 2)])
                      (render-flow (car flows) part ht #t)))
             (for/list ([d (in-list (cdr flows))])
               (indented-newline)
               (printf "* ")
               (parameterize ([current-indent (make-indent 2)])
                 (render-flow d part ht #f)))))))

    (define/override (render-paragraph p part ri)
      (define o (open-output-string))
      (parameterize ([current-output-port o])
        (super render-paragraph p part ri))
      (define to-wrap (regexp-replace* #rx"\n" (get-output-string o) " "))
      (define lines (wrap-line (string-trim to-wrap) (- 72 (current-indent))))
      (write-string (car lines))
      (for ([line (in-list (cdr lines))])
        (newline) (indent) (write-string line))
      (newline)
      null)

    (define/override (render-content i part ri)
      (if (and (element? i)
               (let ([s (element-style i)])
                 (or (eq? 'hspace s)
                     (and (style? s)
                          (eq? 'hspace (style-name s))))))
          (parameterize ([current-preserve-spaces #t])
            (super render-content i part ri))
          (super render-content i part ri)))

    (define/override (render-nested-flow i part ri starting-item?)
      (define s (nested-flow-style i))
      (unless (memq 'decorative (style-properties s))
        (if (and s (or (eq? (style-name s) 'inset)
                       (eq? (style-name s) 'code-inset)))
            (begin (printf "  ")
                   (parameterize ([current-indent (make-indent 2)])
                     (super render-nested-flow i part ri starting-item?)))
            (super render-nested-flow i part ri starting-item?))))

    (define/override (render-other i part ht)
      (cond
        [(symbol? i)
         (display (case i
                    [(mdash) "\U2014"]
                    [(ndash) "\U2013"]
                    [(ldquo) "\U201C"]
                    [(rdquo) "\U201D"]
                    [(lsquo) "\U2018"]
                    [(rsquo) "\U2019"]
                    [(lang) ">"]
                    [(rang) "<"]
                    [(rarr) "->"]
                    [(nbsp) "\uA0"]
                    [(prime) "'"]
                    [(alpha) "\u03B1"]
                    [(infin) "\u221E"]
                    [else (error 'text-render "unknown element symbol: ~e" i)]))]
        [(string? i) (if (current-preserve-spaces)
                         (display (regexp-replace* #rx" " i "\uA0"))
                         (display i))]
        [else (write i)])
      null)

    (super-new)))