(module lowdown-org-table (org-table enable-lowdown-org-tables!)

(import scheme)
(import (chicken base))
(import (chicken irregex))
(import (srfi 14))
(import lowdown)
(import (lowdown lolevel))
(import comparse)

(define pipe-char (is #\|))
(define line-char (in (char-set #\- #\+)))
(define eol (is #\newline))

;; TODO: fix syntactic conflict between table and code block
;; NOTE: an easy way out would be fenced code blocks
;; NOTE: uglier: allow less than four spaces
(define org-rule-line
  (sequence* ((_ space*)
              (_ pipe-char)
              (rule (one-or-more line-char))
              (_ pipe-char)
              (_ line-end))
    (result 'org-rule-line)))

(define (string-rtrim string)
  (irregex-replace '(: (+ space) eos) string ""))

(define org-table-column
  (sequence* ((_ space*)
              (text (as-string (zero-or-more (none-of* pipe-char eol item))))
              (_ pipe-char))
    (result (string-rtrim text))))

(define org-table-line
  (sequence* ((_ space*)
              (_ pipe-char)
              (columns (one-or-more org-table-column))
              (_ line-end))
    (result `(org-table-line ,@columns))))

(define org-table-formula
  (sequence* ((_ space*)
              (_ (char-seq "#+TBLFM:"))
              (_ space*)
              (formula (as-string (one-or-more (none-of* eol item)))))
    (result `(org-table-formula ,formula))))

(define org-table
  (sequence* ((lines (one-or-more (any-of org-rule-line org-table-line)))
              (formula (maybe org-table-formula)))
    (result `(org-table ,@lines))))

(define (org-table-groups lines)
  (let loop ((lines lines)
             (batch '())
             (acc '()))
    (if (null? lines)
        (reverse (if (null? batch) acc (cons (reverse batch) acc)))
        (let ((line (car lines)))
          (if (eqv? line 'org-rule-line)
              (loop (cdr lines) '() (cons (reverse batch) acc))
              (loop (cdr lines) (cons line batch) acc))))))

(define (org-table->sxml _ contents)
  (define (org-table-group->sxml group body-tag col-tag)
    (cons body-tag
          (map (lambda (row)
                 `(tr ,@(map (lambda (col) (list col-tag col)) (cdr row))))
               group)))
  (define (org-table-header->sxml group)
    (org-table-group->sxml group 'thead 'th))
  (define (org-table-body->sxml group)
    (org-table-group->sxml group 'tbody 'td))
  (let ((grouped (org-table-groups contents)))
    `(table
      (@ (class "striped"))
      ,@(if (and (> (length grouped) 1) (= (length (car grouped)) 1))
            (cons (org-table-header->sxml (car grouped))
                  (map org-table-body->sxml (cdr grouped)))
            (map org-table-body->sxml grouped)))))

(define org-table-conversion-rules*
  `((org-table . ,org-table->sxml)))

(define (enable-lowdown-org-tables!)
  (block-hook (cons org-table (block-hook)))
  (markdown-html-conversion-rules*
   (append org-table-conversion-rules*
           (markdown-html-conversion-rules*)))
  (void))

)