cl-scopes/web/dom.lisp

;;;; cl-scopes/web/dom - "Data Output Method" = simple and dedicated HTML generator

(defpackage :scopes/web/dom
  (:use :common-lisp)
  (:local-nicknames (:util :scopes/util)
                    (:hp :html-parse)
                    (:alx :alexandria))
  (:export #:xml-element
           #:elem #:element #:void-element #:render
           #:dlist
           #:a #:dd #:div #:dl #:dt #:label
           #:br #:input
           #:parse #:from-list #:to-list))

(in-package :scopes/web/dom)
(defvar *this* *package*)

;;;; basic definitions

(defgeneric put (s)
  (:method ((s string)) (put-string s))
  (:method ((s symbol)) (put (string-downcase s)))
  (:method ((s cons)) (dolist (e s) (put e))))

(defclass xml-element ()
  ((tag :reader tag :initarg :tag)
   (attrs :reader attrs :initarg :attrs :initform nil)
   (body :reader body :initarg :body :initform nil)))

(defmethod print-object ((el xml-element) stream)
  (format stream "<~a ~s>~s" (tag el) (attrs el) (body el)))

(defun xml-element (tag attrs &rest body)
  (make-instance 'xml-element :tag tag :attrs attrs :body body))

(defmethod put ((el xml-element))
  (let ((tag (tagname el))
        (body (body el)))
    (start tag (attrs el) :close (not body))
    (when body
      (dolist (c body)
        (put c))
      (end tag))))

(defgeneric tagname (el)
  (:method ((el xml-element)) (string-downcase (tag el))))

;;;; element = HTML element - no self-closing of empty elements

(defclass element (xml-element) ())

(defmethod put ((el element))
  (let ((tag (tagname el)))
    (start tag (attrs el))
    (put (body el))
    (end tag)))

(defun elem (tag &optional attrs body)
  (make-instance 'element :tag tag :attrs attrs :body body))

(defun element (tag attrs &rest body)
  (elem tag attrs body))

;;;; void element (e.g. <input ...>): no body, no explicit closing of tag

(defclass void-element (xml-element) ())

(defun void-element (tag &optional attrs body)
  (make-instance 'void-element :tag tag :attrs attrs))

(defmethod put ((el void-element))
  (start (tagname el) (attrs el)))

;;;; automatically define standard HTML elements

(defmacro make-elements (tags &optional (elem-fn 'elem))
  `(progn
     ,@(mapcar (lambda (tag) ;`(make-element ,tag)) tags)))
                 `(defun ,tag (&optional attrs &rest body)
                   (funcall (function ,elem-fn) ',tag attrs body)))
               tags)))

(eval-when (:compile-toplevel :load-toplevel :execute)
    (make-elements (a dd div dl dt label)))

(eval-when (:compile-toplevel :load-toplevel :execute)
    (make-elements (br input) void-element))

;;;; elements with specific functionality

(defun dlist (attrs plist)
  (dl attrs
    (util:loop-plist plist key val append
          (cons (dt nil (string-downcase key)) (dds nil val)))))

(defun dds (attrs cont)
  (if (atom cont)
    (list (dd attrs cont))
    (mapcar #'(lambda (x) (dd nil x)) cont)))

;;;; rendering

(defvar *output* (make-string-output-stream))

(defun render (&rest elems)
  (let ((*output* (make-string-output-stream)))
    (put elems)
    (get-output-stream-string *output*)))

(defun start (tag attrs &key close)
  (put-char #\<)
  (put-string tag)
  (put-attrs attrs)
  (if close
    (put-string " />")
    (put-char #\>)))

(defun end (tag)
  (put-string "</")
  (put-string tag)
  (put-char #\>))

(defun put-string (s)
  (write-string s *output*))

(defun put-char (c)
  (write-char c *output*))

(defun put-attrs (plist)
  ;(loop for (key val . r) on plist by #'cddr do
  (util:loop-plist plist key val do
     (put-char #\Space)
     (when val
       (put-string (string-downcase key))
       (unless (eql val t)
         (put-string "=\"")
         (put-string (attr-str key val))
         (put-char #\")))))

(defun attr-str (key val)
  (case key 
    ((:id :class) (util:to-string val :lower-case t))
    (t (util:to-string val))))

(defun newline ()
  (put-char #\Newline))

;;;; conversions (for testing or manipulation of HTML using dom)

(defun parse (html)
  (hp:parse-html html))

(defun from-list (lst)
  "Create elements from a list of symbols as produced by parse-html."
  (mapcar #'from-list-part lst))

(defun from-list-part (part) 
  (flet ((sym (k) (find-symbol (string k) *this*)))
    (etypecase part
      (string part)
      (symbol (funcall (sym part)))
      (list 
        (let ((tag (car part)) attr)
          (when (consp tag) 
            (setf attr (cdr tag) tag (car tag)))
          (apply (sym tag) attr (from-list (cdr part))))))))
 
(defgeneric to-list (s)
  (:method ((s string)) s)
  (:method ((s symbol)) s)
  (:method ((s cons)) (reverse (mapcar #'to-list s))))

 (defmethod to-list ((el xml-element))
   (let* ((attrs (attrs el))
          (tag (util:to-keyword (tag el)))
          (head (if attrs (cons tag attrs) tag)))
     (cons head (to-list (body el)))))