(in-package #:honey)

(defparameter *line-parsers* nil)
(defparameter *inline-parsers* nil)

(defun parse (str)
 "PARSE STR => HTML

ARGUMENTS AND VALUES:

  STR: a string, representing the markdown
  HTML: a weave style html form

DESCRIPTION:

  Parses the actual markdown, returing the html.  This is the main
  function for the honey package."
 (let
  ((lines (cl-ppcre:split "\\n" str)))
  (mapcar
   #'parse-texts
   (parse-lines (append lines (list ""))))))

(defun textp (x) (and (listp x) (eql 'text (car x))))
(defun as-text (x) (list 'text x))

(defun parse-lines (lines &optional prev)
 (if
  (not lines)
  (list prev)
  (let*
   ((line (car lines))
    (parser
     (getf
      (cadr (find-if (lambda (parser) (funcall (getf parser :checker) line)) (reverse *line-parsers*) :key #'cadr))
      :parser)))
   (when (not parser) (error "Weird!  Couldn't find a match for ~A" line))
   (multiple-value-bind (parsed-line squash-prev suspension) (funcall (funcall parser line) prev)
    (cond
     (squash-prev (parse-lines (cdr lines) parsed-line))
     (suspension
      (let*
       ((regex-to-find (car suspension))
        (function-to-call (cadr suspension))
        (pos
         (position-if
          (lambda (line) (cl-ppcre:scan regex-to-find line))
          (cdr lines))))
       (append
        (list
         prev
         (funcall function-to-call (subseq (cdr lines) 0 (or pos (1- (length lines))))))
        (parse-lines (nthcdr (if pos (1+ pos) (length lines)) (cdr lines))))))
     (t (cons prev (parse-lines (cdr lines) parsed-line))))))))

(defun parse-texts (line)
 (cond
  ((textp line) (parse-inline (cadr line)))
  ((listp line) (mapcar #'parse-texts line))
  (t line)))

(defun parse-inline (str)
 (let
  ((parser
    (getf
     (cadr (find-if (lambda (parser) (funcall (getf parser :checker) str)) (reverse *inline-parsers*) :key #'cadr))
     :parser)))
  (if parser (funcall parser str) str)))

(defmacro defline-parser (regex handler)
 (let
  ((regex (format nil "^~A$" regex)))
  `(progn
    (when (not (find ,regex *line-parsers* :key #'car :test #'string=)) (push (list ,regex nil) *line-parsers*))
    (let
     ((parser (find ,regex *line-parsers* :key #'car :test #'string=)))
     (setf
      (cadr parser)
      (list
       :checker (lambda (str) (cl-ppcre:scan ,regex str))
       :parser (lambda (str)
                (apply
                 (function ,handler)
                 (mapcar
                  #'as-text
                  (coerce (second (multiple-value-list (cl-ppcre:scan-to-strings ,regex str))) 'list))))))))))

(defmacro definline-parser (regex handler)
 (let
  ((regex (format nil "^~A$" regex)))
  `(progn
    (when (not (find ,regex *inline-parsers* :key #'car :test #'string=)) (push (list ,regex nil) *inline-parsers*))
    (let
     ((parser (find ,regex *inline-parsers* :key #'car :test #'string=)))
     (setf
      (cadr parser)
      (list
       :checker (lambda (str) (cl-ppcre:scan ,regex str))
       :parser (lambda (str)
                (apply (function ,handler)
                 (mapcar
                  #'parse-inline
                  (coerce (second (multiple-value-list (cl-ppcre:scan-to-strings ,regex str))) 'list))))))))))

; each parser function needs to return a function that takes the previous line and returns
;
; the values:
;   the new element
;   whether the previous line should be consumed (optional)
;   an optional list with two items, which suspends parsing until regex is found
;     - the regex to end the suspension
;     - the function to call with the list of lines

(defun prev-h2 ()
 (lambda (prev)
  (if (textp prev) (values (h2 prev) t) (hr))))

(defun prev-h1 ()
 (lambda (prev)
  (if (textp prev) (values (h1 prev) t) (hr))))

(defun inline-h1 (text) (lambda (prev) (h1 text)))
(defun inline-h2 (text) (lambda (prev) (h2 text)))
(defun inline-h3 (text) (lambda (prev) (h3 text)))
(defun inline-h4 (text) (lambda (prev) (h4 text)))
(defun inline-h5 (text) (lambda (prev) (h5 text)))

(defun list-item (text)
 (lambda (prev)
  (let
   ((li (li text)))
   (if (and prev (listp prev) (eql 'ul (car prev)))
    (values (append prev (list li)) t)
    (ul li)))))

(defun emptiness ()
 (lambda (prev)
  (cond
   ((textp prev) (values (p prev) t)))))

(defun default (text)
 (lambda (prev) (declare (ignore prev)) text))

(defun codefence (codetype)
 (lambda (prev)
  (declare (ignore prev))
  (values
   nil
   nil
   (list
    "^```$"
    (lambda (lines)
     (pre
      (code
       (format nil "~{~A~%~}" lines))))))))

(defline-parser "-+" prev-h2)
(defline-parser "=+" prev-h1)

; These need to be in reverse order so they match correctly
(defline-parser "##### *(.*)" inline-h5)
(defline-parser "#### *(.*)" inline-h4)
(defline-parser "### *(.*)" inline-h3)
(defline-parser "## *(.*)" inline-h2)
(defline-parser "# *(.*)" inline-h1)

; Ignore codefence
(defline-parser "(```.*```.*)" default)

(defline-parser "```(.*)" codefence)

; If we start with a space after the asterisk, we really do want a list
(defline-parser " *\\* (.*)" list-item)
; Ignore list-tiem
(defline-parser "(\\*\\*.*\\*\\*.*)" default)
(defline-parser "(\\*.*\\*.*)" default)
(defline-parser " *\\* *(.*)" list-item)
(defline-parser " *" emptiness)
(defline-parser "(.*)" default)

(defun strength (before during after)
 (list before (span :style-font-weight "bold" during) after))

(defun emphasis (before during after)
 (list before (span :style-font-style "italic" during) after))

(defun md-link (before text md-link after)
 (list before (a :href md-link (parse-texts text)) after))

(defun inline-code (before during after)
 (list before (code during) after))

(definline-parser "(.*)\\[([^\\]]*)\\]\\(([^)]*)\\)(.*)" md-link)
(definline-parser "(.*)\\*\\*(.*)\\*\\*(.*)" strength)
(definline-parser "(.*)\\*(.*)\\*(.*)" emphasis)
(definline-parser "(.*)_(.*)_(.*)" emphasis)
(definline-parser "(.*)```(.*)```(.*)" inline-code)