;;;; stark - markup language

(defpackage stark-output-html
  (:use :cl)
  (:export :generate))

(in-package :stark-output-html)

(defun booleanp (value)
  "Check whether the given value is a strictly boolean value or not."
  (or (null value) (eq value t)))

(defun symbol->string (symbol)
  "Convert the given symbol into a (lower-case) string."
  (string-downcase (string symbol)))

(defun wrap-tag (name body &key (attributes nil) (self-closing nil))
  "Writes the HTML tree in `body' wrapped with a tag with the given `name', with
the optionally given `attributes', to the `*standard-output*'. If `self-closing' is
non-`nil', the tag to be written is a leaf tag and `body' must be `nil'."
  (let ((tag-name (symbol->string name))) 
    (write-char #\<)
    (princ tag-name)
    (do ((attrs attributes (cddr attrs)))
        ((null attrs))
      (let ((key (symbol->string (car attrs)))
            (value (cadr attrs)))
        (write-char #\space)
        (princ key)
        (unless (booleanp value)
            (write-char #\=)
            (write-char #\")
            (escape-html value)
            (write-char #\"))))
    (write-char #\>)
    (when (and self-closing body)
      (error "Body provided for self-closing <~A> tag." tag-name))
    (when body
      (visit-tree body))
    (unless self-closing
      (write-char #\<)
      (write-char #\/)
      (princ tag-name)
      (write-char #\>))
    (values)))

(defun escape-html (text)
  "Escape special characters with appropriate HTML entities in the given `text' to
the `*standard-output'."
  (labels ((map-entities (c)
             (case c
               (#\& "&amp;")
               (#\" "&quot;")
               (#\' "&apos;")
               (#\< "&lt;")
               (#\> "&gt;")
               (otherwise nil)))
           (escape-char (c)
             (let ((entity (map-entities c)))
               (if (null entity)
                   (write-char c)
                   (princ entity)))))
    (map nil #'escape-char text)
    (values)))

(defun visit-tree (tree)
  "Traverse the given `tree' to generate HTML output.

Trees with (car tree) as 'tree will iterate over all its children. For 'text, the
`html-escape'd text in (cadr tree) will be written; while in the case of 'raw,
(cadr tree) will be output as-is. For everything else, `wrap-tag' will be invoked
to process it."
  (unless (consp tree)
    (error "Invalid tree to visit: ~A" tree))
  ;; KLUDGE: Can not use `case' because symbols interned in different packages are not
  ;; `eql', but `string=' instead. Need to implement a version of `case' which uses
  ;; `string=' for equality checks instead.
  (cond
    ((string= (car tree) 'text)
     (escape-html (the string (cadr tree))))
    ((string= (car tree) 'raw)
     (princ (the string (cadr tree))))
    ((string= (car tree) 'heading)
     (let* ((depth (cadr tree))
            (tag-name (concatenate 'string "h" (write-to-string depth)))
            (body (caddr tree)))
       (wrap-tag tag-name body)))
    ((string= (car tree) 'newline)
     (terpri))
    ((string= (car tree) 'tree)
     (mapcar #'visit-tree (cdr tree)))
    (t (apply #'wrap-tag tree)))
  (values))

(defun generate (tree)
  (visit-tree tree))

(defpackage stark-parse
  (:use :cl)
  (:export :parse-input))

(in-package :stark-parse)

(defun paragraph-handler (line tree)
  (if (or (null line) (zerop (length line)))
      (values `(p (tree ,(parse-inline (join-by-spaces (nreverse tree))))) t)
      (values (cons line tree) nil)))

(defun parse-inline (text)
  `(text ,text))

(defconstant +whitespace-chars+
  (make-array 6 :element-type 'character
              :initial-contents '(#\Newline #\Space #\Tab #\Return #\Vt #\Page)))

(defun whitespacep (c)
  (find c +whitespace-chars+))

(defvar *header-char* #\=)

(defun headerp (line)
  (let ((pos (position-if #'(lambda (c) (char/= c *header-char*)) line)))
    ;; `line' must start with one or more `*header-char*' characters, followed by
    ;; at least a whitespace character if there are any more left on that line.
    (or (null pos) (and (not (zerop pos)) (whitespacep (char line pos))))))

(defun header-handler (line tree)
  (if (or (null line) (zerop (length line)))
      (let* ((result (nreverse tree))
             (depth (first result))
             (tree (rest result)))
        (values `(heading ,depth (tree ,(parse-inline (join-by-spaces tree))))
                t))
      (if (null tree)
          (let* ((end-header-char-pos
                  (position-if #'(lambda (c) (char/= c *header-char*)) line))
                 (text-start-pos (and end-header-char-pos
                                      (position-if #'(lambda (c) (not (whitespacep c)))
                                                   line :start end-header-char-pos)))
                 (text (and end-header-char-pos text-start-pos
                            (subseq line text-start-pos)))
                 (depth (or end-header-char-pos (length line)))
                 (tree (list depth)))
            (when text
              (push text tree))
            (values tree nil))
          (values (cons line tree) nil))))

(defparameter *input-handlers*
  (list (cons #'headerp #'header-handler)
        (cons #'(lambda (x) (declare (ignore x)) t) #'paragraph-handler))
  "A list of input handlers that are sequentially invoked to find the proper one to use.")

(defun find-handler (line)
  (dolist (handler *input-handlers*)
    (when (funcall (car handler) line)
      (return (cdr handler)))))

(defun join-by-spaces (lines)
  (do ((s (make-string-output-stream)))
      ((null lines) (get-output-stream-string s))
    (princ (car lines) s)
    (when (cdr lines)
      (write-char #\space s))
    (pop lines)))

(defun parse-input ()
  (do ((result '(tree)) branch handler at-eof)
      (at-eof (reverse result))
    (multiple-value-bind (line eof)
        (read-line *standard-input* nil)
      (when (and (null handler) (not (zerop (length line))))
        (setf handler (find-handler line)))
      (multiple-value-bind (new-branch done)
          (funcall handler line branch)
        (setf branch new-branch)
        (when done
          (setf handler nil)
          (push branch result)
          (push '(newline) result)
          (setf branch nil)))
      (when eof
        (when handler
          (multiple-value-bind (branch done)
              (funcall handler nil branch)
            (unless done
              (error "Unfinished work in the hander ~A with tree ~A" handler branch))
            (push branch result)))
        (setf at-eof t)))))