(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 #1'(funcall (getf $1 :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) (funcall (funcall parser line) prev)
    (if squash-prev
     (parse-lines (cdr lines) parsed-line)
     (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 #1'(funcall (getf $1 :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 (utils:strassoc ,regex *line-parsers*)) (push (list ,regex nil) *line-parsers*))
    (setf (utils:strassoc ,regex *line-parsers*)
     (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 (utils:strassoc ,regex *inline-parsers*)) (push (list ,regex nil) *inline-parsers*))
    (setf (utils:strassoc ,regex *inline-parsers*)
     (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 either
;
; a single element being the new element, and optionally a second values option about whether
; the previous line should be consumed

(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 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))

(defline-parser "-+" prev-h2)
(defline-parser "=+" prev-h1)
(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))

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