(declare (module (jimmy emit)))

(import scheme (chicken base)
        (jimmy util)
        (chicken format)
        (chicken irregex)
        (chicken string))

(define-public (emit document)
  (for-each display
            (map format-block document)))

(define-public formats
  ;;; (type line-format block-format [line-in-block-format])
  ;; these default to gemtext
  '((para (line . "~A ")
          (block . "~A~%~%"))
    (verb (line . "~A~%")
          (block . "```~%~A```~%~%"))
    (link (line . "=> ~A ~A~%")
          (block . "~A~%")
          (inline . "~%=> ~A ~A~%")) ;TODO: have 2 args to format
    (list (line . "* ~A~%")
          (block . "~A~%"))
    (quot (line . "~A ")
          (block . "> ~A~%~%"))
    (hdr1 (line . "# ~A~%")
          (block . "~A~%"))
    (hdr2 (line . "## ~A~%")
          (block . "~A~%"))
    (hdr3 (line . "### ~A~%")
          (block . "~A~%"))
    (default
      (line . "~A")
      (block . "~A~%~%"))))

(define-public filters
  `((para
     (line . ,(o (char->tag "*" "<strong>" "</strong>")
                 (char->tag "_" "<em>" "</em>")
                 (char->tag "`" "<code>" "</code>")
                 string-join))
     (block . ,(lambda (ln)
                 (irregex-replace/all '(: bol (* " ")) ln ""))))
    (link
     (line . ,(lambda (ln)
                (let ((ws (cond ((list? ln) ln)
                                ((string? ln) (string-split ln)))))
                  (let ((x (list (car ws) (string-join (cdr ws)))))
                    x)))))
    (default
      (line . ,(lambda (x) (print x) (if (list? x) x (list x))))
      (block . ,identity))))

(define (string-join ss #!optional sep)
  (if (string? ss) ss
      (string-intersperse ss (or sep " "))))

(define (char->tag char beg end)
  (lambda (str)
    (irregex-replace/all `(: ($ (or bos space))
                             ,char ($ (+ (~ ,char))) ,char
                             ($ (or space eos)))
                         str
                         1 beg 2 end 3)))

(define (get-from from type subtype)
  (or (alist-walk from type subtype)
      (get-from from 'default subtype)))

(define (get-format type subtype) (get-from formats type subtype))
(define (get-filter type subtype) (get-from filters type subtype))

(define (format-line fmt line type)
  (cond
   ;; if LINE is a string, wrap it in a list
   ((string? line)
    (sprintf (get-format type 'line)
             ((get-filter type 'line) line)))
   ;; if it's a list of strings, join them together and filter them
   ((and (list? line)
         (string? (car line)))
    (sprintf (get-format type 'line)
             (apply string-append ((get-filter type 'line) line))))
   ;; if the car of LINE is a symbol, it's an inline thing.
   ((and (list? line)
         (symbol? (car line)))
    (sprintf* (get-format (car line) 'inline)
              ((get-filter (car line) 'line) (cdr line))))
   (else (error "Malformed line" line))))

(define (format-block block)
  (if (assq (car block) formats)
      (let* ((type (car block))
             (data (cdr block))
             (text (cond
                    ((string? data) data)
                    ((list? data)
                     (apply string-append
                            (map (lambda (ln)
                                   (format-line (get-format type 'line)
                                                ln
                                                type))
                                 data)))
                    (else (error "Malformed block" block)))))
        (sprintf (get-format type 'block)
                 ((get-filter type 'block) text)))
      ""))

(define (sprintf* fmt lis)
  (let loop ((num (length (irregex-extract "~[aA]" fmt)))
             (lis lis)
             (out '()))
    (cond
     ((null? lis)
      (apply sprintf fmt (reverse out)))
     ((= 1 num)
      (loop 0 '() (cons (string-join lis) out)))
     (else
      (loop (- num 1)
            (cdr lis)
            (cons (car lis) out))))))