166 lines
4.4 KiB
Common Lisp
166 lines
4.4 KiB
Common 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))
|
|
|
|
(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))
|
|
|
|
;;;; create elements from list of symbols
|
|
|
|
(defun from-list (lst)
|
|
(mapcar #'(lambda (part)
|
|
(etypecase part
|
|
(string part)
|
|
(symbol (funcall (find-symbol (string part) *this*)))
|
|
(list
|
|
(etypecase (car part)
|
|
(symbol (apply (find-symbol (string (car part)) *this*)
|
|
nil (from-list (cdr part))))
|
|
(list (apply (find-symbol (string (caar part)) *this*)
|
|
(cdar part) (from-list (cdr part))))
|
|
)))) lst))
|
|
|
|
;;;; parsing (for testing or manipulation of HTML using dom)
|
|
|
|
(defun parse (html)
|
|
(hp:parse-html html))
|