generate-html.lisp ($1892940) · Snippets

The improved version should support everything but CSS selectors and JS.

The original version from 2019-07-07 is archived in this comment because I don't think Gitlab has history for Snippits.

(deftype html-empty-element ()
  '(member :area :base :br :col :embed :hr :img :input :keygen :link :meta
    :param :source :track :wbr))

(deftype escaped-character ()
  '(member #\< #\> #\&))

(defun generate-attributes (contents stream)
  (if (and contents (keywordp (car contents)))
      (loop :for sublist :on contents :by #'cddr
            :until (not (keywordp (car sublist)))
            :do (destructuring-bind (keyword value &rest rest)
                    sublist
                  (declare (ignore rest))
                  (format stream " ~A=\"" (string-downcase (symbol-name keyword)))
                  (typecase value
                    (string (write-escaped-string value stream t))
                    (t (write-escaped-string (format nil "~A" value) stream t)))
                  (write-char #\" stream))
            :finally (return sublist))
      contents))

(defun write-escaped-string (string stream &optional attribute?)
  (declare (string string))
  (loop :for character :across string
        :do (case character
              (#\< (write-string "&lt;" stream))
              (#\> (write-string "&gt;" stream))
              (#\& (write-string "&amp;" stream))
              (#\" (if attribute?
                       (write-string "&quot;" stream)
                       (write-char character stream)))
              (t (write-char character stream)))))

(defun generate-html (expression &key (stream *standard-output*) (xml? nil))
  (destructuring-bind (tag &rest contents) expression
    (let ((empty-element? (typep tag 'html-empty-element)))
      (format stream "<~A" (string-downcase (symbol-name tag)))
      (let ((contents (generate-attributes contents stream)))
        (if (and xml? empty-element?)
            (write-string " />" stream)
            (write-char #\> stream))
        (when (and empty-element? contents)
          (error "Empty elements cannot have a body."))
        (dolist (item contents)
          (typecase item
            (list (generate-html item :stream stream))
            (string (write-escaped-string item stream))
            (t (write-escaped-string (format nil "~A" item) stream)))))
      (unless empty-element?
        (format stream "</~A>" (string-downcase (symbol-name tag)))))))

(defun main ()
  (with-output-to-string (output)
    (write-string "<!doctype html>" output)
    (generate-html
     `(:html
       (:head (:title "Hello"))
       (:body (:p "This is " (:em "the") " " (:strong "message") " body.")
              (:p "This is a link to " (:a :href "https://example.com"
                                           "Example.com"))
              (:p "A paragraph uses a " (:code "<p>") " tag" (:br) "& everything goes inside of the "
                  (:code "<html>") " tag.")))
     :stream output)))

Note: This code was further developed in the cl-documents repository.