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

(define current-markdown-link-sections (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 note-depth (make-parameter 0))
(define in-toc (make-parameter #f))

(define markdown-part-tag 'markdown-section)

(define (render-mixin %)
  (class %
    
    (define/override (current-render-mode)
      '(markdown))

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

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

    (inherit render-block
             format-number
             number-depth)

    (define/override (collect-part-tags d ci number)
      (for ([t (part-tags d)])
        (let ([t (generate-tag t ci)])
          (collect-put! ci
                        t
                        (vector (or (part-title-content d) '("???"))
                                (add-current-tag-prefix t)
                                number
                                markdown-part-tag)))))

    (define/override (render-part d ht)
      (let ([number (collected-info-number (part-collected-info d ht))])
        (unless (part-style? d 'hidden)
          (printf (string-append (make-string (add1 (number-depth number)) #\#) " "))
          (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))

      (define tick? (member (style-name (table-style i))
                            (list 'boxed "defmodule" "RktBlk")))

      (cond
        [(null? flowss) null]

        [(and tick? (not (in-code?)))
          (displayln "```racket")
          (parameterize ([in-code? #t])
            (render-table i part ht inline?))
          (displayln "```")]

        [else
          (define 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))
          (define widths (map (lambda (col)
                                (for/fold ([d 0]) ([i (in-list col)])
                                  (if (eq? i 'cont)
                                      0
                                      (apply max d (map string-length i)))))
                              (apply map list strs)))
          (define x-length (lambda (col) (if (eq? col 'cont) 0 (length col))))
          (for/fold ([indent? #f]) ([row (in-list strs)])
            (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)
                                  "")))])
                (for/fold ([indent? indent?]) ([sub-row (in-list row*)])
                  (when indent? (indent))
                  (for/fold ([space? #f])
                      ([col (in-list sub-row)]
                       [w (in-list widths)])
                    (let ([col (if (eq? col 'cont) "" col)])
                      (display (regexp-replace* #rx"\uA0" col " "))
                      (display (make-string (max 0 (- w (string-length col))) #\space)))
                    #t)
                  (newline)
                  #t)))
            #t)])
      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 (write-note)
        (write-string (make-string (note-depth) #\>))
        (unless (zero? (note-depth))
          (write-string " ")))
      (cond
        [(in-toc)
         (write-note)
         (super render-paragraph p part ri)
         ;; two spaces at a line end creates a line break:
         (write-string "  ")]
        [else
         (define o (open-output-string))
         (parameterize ([current-output-port o])
           (super render-paragraph p part ri))
         ;; 1. Remove newlines so we can re-wrap the text.
         ;;
         ;; 2. Combine adjacent code spans into one. These result from
         ;; something like @racket[(x y)] being treated as multiple
         ;; RktXXX items rather than one. (Although it would be
         ;; more-correct to handle them at that level, I don't easily see
         ;; how. As a result I'm handling it after-the-fact, at the
         ;; text/Markdown stage.)
         (define to-wrap (regexp-replaces (get-output-string o)
                                          '([#rx"\n" " "]   ;1
                                            [#rx"``" ""]))) ;2
         (define lines (wrap-line (string-trim to-wrap) (- 72 (current-indent))))
         (write-note)
         (write-string (car lines))
         (for ([line (in-list (cdr lines))])
           (newline) (indent) (write-note) (write-string line))])
      (newline)
      null)

    (define/private (content-style e)
      (cond
       [(element? e) (element-style e)]
       [(multiarg-element? e) (multiarg-element-style e)]
       [else #f]))

    (define in-bold? (make-parameter #f))
    (define in-italic? (make-parameter #f))
    (define in-code? (make-parameter #f))
    (define in-link? (make-parameter #f))
    (define preserving-spaces? (make-parameter #f))

    (define (bold? i)
      (and (element? i) (eq? (element-style i) 'bold)))

    (define (italic? i)
      (and (element? i) (eq? (element-style i) 'italic)))

    (define (emph? i)
      (and (element? i) (eq? (element-style i) 'emph)))

    (define (code? i)
      (and (element? i)
           (let ([s (element-style i)])
             (or (eq? 'tt s)
                 (and (style? s)
                      (style-name s)
                      (regexp-match? #rx"^Rkt[A-Z]" (style-name s)))))))

    (define (link? i)
      (let ([s (content-style i)])
        (and (style? s) (findf target-url? (style-properties s)))))

    (define (link-from i)
      (target-url-addr (findf target-url? (style-properties (content-style i)))))

    (define (preserve-spaces? i)
      (and (element? i)
           (let ([s (element-style i)])
             (or (eq? 'hspace s)
                 (and (style? s)
                      (eq? 'hspace (style-name s)))))))

    (define (sanitize-parens str)
      (regexp-replace #rx"[\\(\\)]" str "\\&"))

    (define/override (render-content i part ri)
      (define (recurse-wrapped str param)
        (display str)
        (begin0
          (parameterize ([param #t])
            (render-content i part ri))
          (display str)))

      (cond
        [(and (code? i) (not (in-code?)))
          (recurse-wrapped "`" in-code?)]

        [(and (bold? i) (not (in-bold?)) (not (in-code?)))
          (recurse-wrapped "**" in-bold?)]

        [(and (italic? i) (not (in-italic?)) (not (in-code?)))
          (recurse-wrapped "_" in-italic?)]

        [(and (emph? i) (not (in-code?)))
         (display "​_") ;; zero-width space, underscore
         (begin0
             (super render-content i part ri)
           (display "_​"))] ;; underscore, zero-width space

        [(and (preserve-spaces? i) (not (preserving-spaces?)))
          (parameterize ([preserving-spaces? #t])
            (render-content i part ri))]

        [(and (link? i) (not (in-link?)))
          (let ([link (link-from i)])
            (display "[")
            (begin0
              (parameterize ([in-link? #t])
                (render-content i part ri))
              (printf "](~a)" (sanitize-parens link))))]

        [(and (link-element? i)
              (current-markdown-link-sections)
              (not (in-link?))
              ;; Link to a part within this document?
              (let ([vec (resolve-get part ri (link-element-tag i))])
                (and (vector? vec)
                     (= 4 (vector-length vec))
                     (eq? markdown-part-tag (vector-ref vec 3))
                     vec)))
         => (lambda (vec)
              (define s (string-append
                         (let ([s (if (vector-ref vec 2)
                                      (format-number (vector-ref vec 2) '() #t)
                                      '())])
                           (if (null? s)
                               ""
                               (string-append (car s) " ")))
                         (content->string (vector-ref vec 0))))
              (display "[")
              (begin0
                (parameterize ([in-link? #t])
                  (super render-content i part ri))
                (display "](#")
                (display (regexp-replace* #" "
                                          (regexp-replace* #rx"[^a-zA-Z0-9_ -]" (string-downcase s) "")
                                          #"-"))
                (display ")")))]

        [else (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))
        (define note? (equal? (style-name s) "refcontent"))
        (define toc? (equal? (style-name s) 'table-of-contents))
        (when note?
          (note-depth (add1 (note-depth))))
        (begin0 (parameterize ([in-toc (or toc? (in-toc))])
                  (super render-nested-flow i part ri starting-item?))
          (when note?
            (note-depth (sub1 (note-depth)))))))

    (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 'markdown-render "unknown element symbol: ~e"
                                 i)]))]
        [(string? i)
         (let* ([i (cond
                     [(in-code?)
                      (regexp-replace** i '([#rx"``" . "\U201C"]
                                            [#rx"''" . "\U201D"]))]
                     [(or (in-link?)
                          (regexp-match? #rx"^[(]" i)
                          (regexp-match? #rx"[]][(]" i))
                      (regexp-replace* #px"([#_*`\\[\\(\\]\\)]{1})" i "\\\\\\1")]
                     [else
                      ;; Avoid escaping parentheses
                      (regexp-replace* #px"([#_*`\\[\\]]{1})" i "\\\\\\1")])]
                [i (if (preserving-spaces?)
                       (regexp-replace* #rx" " i "\uA0")
                       i)])
           (display i))]
        [else (write i)])
      null)

    (define/override (table-of-contents part ri)
      (define t (super table-of-contents part ri))
      (cond
        [(current-markdown-link-sections)
         ;; Table generated by `table-of-contents` always has one
         ;; column, and each row has one paragraph that starts
         ;; with a 'hspace element to indent
         (nested-flow
          (style 'table-of-contents null)
          (for/list ([p (map car (table-blockss t))])
            (define c (paragraph-content p))
            (define keep-c (cdr c))
            (define (spaces->depth n)
              (add1 (quotient (- n 4) 2)))
            (for/fold ([p (paragraph plain keep-c)]) ([s (in-range
                                                          (spaces->depth
                                                           (string-length (car (element-content (car c))))))])
              (nested-flow (style "refcontent" null) (list p)))))]
        [else t]))

    (super-new)))

(define (regexp-replace** str ptns&reps)
  (for/fold ([str str])
            ([ptn (map car ptns&reps)]
             [rep (map cdr ptns&reps)])
    (regexp-replace* ptn str rep)))