2024-02-03 18:46:48 +09:00
|
|
|
(in-package :piccolo)
|
2018-06-24 13:08:30 -04:00
|
|
|
|
2018-06-25 00:42:43 -04:00
|
|
|
(defclass element ()
|
|
|
|
|
((tag :initarg :tag
|
|
|
|
|
:accessor element-tag)
|
|
|
|
|
(attrs :initarg :attrs
|
|
|
|
|
:accessor element-attrs)
|
|
|
|
|
(children :initarg :children
|
|
|
|
|
:accessor element-children)))
|
|
|
|
|
|
|
|
|
|
(defclass builtin-element (element) ())
|
|
|
|
|
|
|
|
|
|
(defclass builtin-element-with-prefix (builtin-element)
|
|
|
|
|
((prefix :initarg :prefix
|
|
|
|
|
:accessor element-prefix)))
|
|
|
|
|
|
|
|
|
|
(defclass user-element (element)
|
2018-06-30 17:32:09 -04:00
|
|
|
((expand-to :initarg :expander
|
|
|
|
|
:accessor user-element-expander)))
|
2018-06-25 00:42:43 -04:00
|
|
|
|
2018-06-28 10:09:21 -04:00
|
|
|
(defun make-builtin-element (&key tag attrs children)
|
|
|
|
|
(make-instance 'builtin-element :tag tag :attrs attrs
|
|
|
|
|
:children (escape-children children)))
|
2018-06-25 00:42:43 -04:00
|
|
|
|
2018-06-28 10:09:21 -04:00
|
|
|
(defun make-builtin-element-with-prefix (&key tag attrs children prefix)
|
|
|
|
|
(make-instance 'builtin-element-with-prefix :tag tag :attrs attrs :prefix prefix
|
|
|
|
|
:children (escape-children children)))
|
2018-06-24 13:08:30 -04:00
|
|
|
|
2018-06-30 17:32:09 -04:00
|
|
|
(defun make-user-element (&rest args &key tag attrs children expander)
|
|
|
|
|
(make-instance 'user-element :tag tag :attrs attrs :expander expander
|
2018-06-28 10:09:21 -04:00
|
|
|
:children (escape-children children)))
|
|
|
|
|
|
2018-06-30 17:32:09 -04:00
|
|
|
(defmethod user-element-expand-to ((element user-element))
|
|
|
|
|
(funcall (user-element-expander element)
|
|
|
|
|
(element-tag element)
|
|
|
|
|
(element-attrs element)
|
|
|
|
|
(element-children element)))
|
|
|
|
|
|
2018-06-28 10:09:21 -04:00
|
|
|
(defstruct (attrs (:constructor %make-attrs))
|
|
|
|
|
alist)
|
|
|
|
|
|
|
|
|
|
(defvar *escape-html* :utf8
|
|
|
|
|
"Specify the escape option when generate html, can be :UTF8, :ASCII, :ATTR or NIL.
|
|
|
|
|
If :UTF8, escape only #\<, #\> and #\& in body, and \" in attribute keys. #\' will
|
2024-02-03 18:46:48 +09:00
|
|
|
in attribute keys will not be escaped since piccolo will always use double quote for
|
2018-06-28 10:09:21 -04:00
|
|
|
attribute keys.
|
|
|
|
|
If :ASCII, besides what escaped in :UTF8, also escape all non-ascii characters.
|
|
|
|
|
If :ATTR, only #\" in attribute values will be escaped.
|
|
|
|
|
If NIL, nothing is escaped and programmer is responsible to escape elements properly.
|
|
|
|
|
When given :ASCII and :ATTR, it's possible to insert html text as a children, e.g.
|
|
|
|
|
(div :id \"container\" \"Some <b>text</b>\")")
|
|
|
|
|
|
2018-06-28 23:04:10 -04:00
|
|
|
(defun make-attrs (&key alist)
|
2018-06-28 10:09:21 -04:00
|
|
|
(if *escape-html*
|
|
|
|
|
(%make-attrs :alist (escape-attrs-alist alist))
|
|
|
|
|
(%make-attrs :alist alist)))
|
2018-06-24 13:08:30 -04:00
|
|
|
|
2018-06-27 13:00:53 -04:00
|
|
|
(defmethod (setf attr) (value (attrs attrs) key)
|
2018-06-30 17:32:09 -04:00
|
|
|
(setf (aget (attrs-alist attrs) key) value))
|
2018-06-27 10:01:18 -04:00
|
|
|
|
2018-06-27 13:00:53 -04:00
|
|
|
(defmethod delete-attr ((attrs attrs) key)
|
|
|
|
|
(delete-from-alistf (attrs-alist attrs) key))
|
2018-06-27 10:01:18 -04:00
|
|
|
|
2018-06-27 13:00:53 -04:00
|
|
|
(defmethod attr ((attrs attrs) key)
|
|
|
|
|
(aget (attrs-alist attrs) key))
|
2018-06-27 10:01:18 -04:00
|
|
|
|
2018-06-27 13:00:53 -04:00
|
|
|
(defmethod (setf attr) (value (element element) key)
|
|
|
|
|
(setf (attr (element-attrs element) key) value))
|
|
|
|
|
|
|
|
|
|
(defmethod delete-attr ((element element) key)
|
|
|
|
|
(delete-attr (element-attrs element) key))
|
|
|
|
|
|
|
|
|
|
(defmethod attr ((element element) key)
|
2018-06-30 17:32:09 -04:00
|
|
|
(attr (element-attrs element) key))
|
2018-06-27 10:01:18 -04:00
|
|
|
|
2018-06-27 09:32:41 -04:00
|
|
|
(defvar *builtin-elements* (make-hash-table))
|
|
|
|
|
|
2018-06-25 00:42:43 -04:00
|
|
|
(defun html (&rest attrs-and-children)
|
|
|
|
|
(multiple-value-bind (attrs children)
|
|
|
|
|
(split-attrs-and-children attrs-and-children)
|
|
|
|
|
(make-builtin-element-with-prefix :tag "html" :attrs attrs
|
|
|
|
|
:children children
|
|
|
|
|
:prefix "<!DOCTYPE html>")))
|
2018-06-27 09:32:41 -04:00
|
|
|
(setf (gethash :html *builtin-elements*) t)
|
2018-06-25 00:42:43 -04:00
|
|
|
|
2018-06-24 13:08:30 -04:00
|
|
|
(defmacro define-builtin-element (element-name)
|
2023-12-21 12:40:05 -05:00
|
|
|
`(progn
|
|
|
|
|
(defun ,element-name (&rest attrs-and-children)
|
|
|
|
|
(multiple-value-bind (attrs children)
|
|
|
|
|
(split-attrs-and-children attrs-and-children)
|
|
|
|
|
(make-builtin-element :tag (string-downcase (mkstr ',element-name))
|
|
|
|
|
:attrs attrs :children children)))
|
|
|
|
|
(defun ,(alexandria:symbolicate element-name '*) (attrs children)
|
2018-06-25 00:42:43 -04:00
|
|
|
(make-builtin-element :tag (string-downcase (mkstr ',element-name))
|
|
|
|
|
:attrs attrs :children children))))
|
2018-06-24 13:08:30 -04:00
|
|
|
|
|
|
|
|
(defmacro define-and-export-builtin-elements (&rest element-names)
|
|
|
|
|
`(progn
|
|
|
|
|
,@(mapcan (lambda (e)
|
|
|
|
|
(list `(define-builtin-element ,e)
|
2018-06-27 09:32:41 -04:00
|
|
|
`(setf (gethash (make-keyword ',e) *builtin-elements*) t)
|
2023-12-21 12:40:05 -05:00
|
|
|
`(setf (gethash (make-keyword ,(format nil "~a*" e)) *builtin-elements*) t)
|
2018-06-24 13:08:30 -04:00
|
|
|
`(export ',e)))
|
|
|
|
|
element-names)))
|
|
|
|
|
|
2018-06-24 20:42:55 -04:00
|
|
|
(define-and-export-builtin-elements
|
2018-06-24 13:08:30 -04:00
|
|
|
a abbr address area article aside audio b base bdi bdo blockquote
|
|
|
|
|
body br button canvas caption cite code col colgroup data datalist
|
|
|
|
|
dd del details dfn dialog div dl dt em embed fieldset figcaption
|
2018-06-25 00:42:43 -04:00
|
|
|
figure footer form h1 h2 h3 h4 h5 h6 head header hr i iframe
|
2018-06-24 13:08:30 -04:00
|
|
|
img input ins kbd label legend li link main |map| mark meta meter nav
|
|
|
|
|
noscript object ol optgroup option output p param picture pre progress
|
|
|
|
|
q rp rt ruby s samp script section select small source span strong
|
|
|
|
|
style sub summary sup svg table tbody td template textarea tfoot th
|
|
|
|
|
thead |time| title tr track u ul var video wbr)
|
|
|
|
|
|
|
|
|
|
(defmethod print-object ((attrs attrs) stream)
|
|
|
|
|
(if (attrs-alist attrs)
|
|
|
|
|
(format stream " ~{~a=~s~^ ~}" (alist-plist* (attrs-alist attrs)))
|
|
|
|
|
(format stream "")))
|
|
|
|
|
|
2023-12-21 12:40:05 -05:00
|
|
|
(defun self-closing-p (element)
|
|
|
|
|
(gethash (if (symbolp element)
|
|
|
|
|
element
|
|
|
|
|
(intern (string-downcase element) #.*package*))
|
|
|
|
|
#.(let ((self-closing-tags (make-hash-table)))
|
|
|
|
|
(loop :for tag :in '(area base br col embed hr img input keygen
|
|
|
|
|
link meta param source track wbr)
|
|
|
|
|
:do (setf (gethash tag self-closing-tags) tag))
|
|
|
|
|
self-closing-tags)))
|
|
|
|
|
|
2018-06-24 13:08:30 -04:00
|
|
|
(defmethod print-object ((element element) stream)
|
|
|
|
|
(if (element-children element)
|
|
|
|
|
(format stream (if (rest (element-children element))
|
|
|
|
|
"~@<<~a~a>~2I~:@_~<~@{~a~^~:@_~}~:>~0I~:@_</~a>~:>"
|
|
|
|
|
"~@<<~a~a>~2I~:_~<~a~:>~0I~:_</~a>~:>")
|
|
|
|
|
(element-tag element)
|
|
|
|
|
(element-attrs element)
|
|
|
|
|
(element-children element)
|
|
|
|
|
(element-tag element))
|
2023-12-21 12:40:05 -05:00
|
|
|
(format stream (if (self-closing-p (element-tag element))
|
|
|
|
|
"<~a~a>"
|
|
|
|
|
"<~a~a></~a>")
|
|
|
|
|
(element-tag element)
|
|
|
|
|
(element-attrs element)
|
|
|
|
|
(element-tag element))))
|
2018-06-24 13:08:30 -04:00
|
|
|
|
2018-06-25 00:42:43 -04:00
|
|
|
(defmethod print-object ((element builtin-element-with-prefix) stream)
|
2018-06-27 09:32:41 -04:00
|
|
|
(format stream "~a~%" (element-prefix element))
|
2018-06-25 00:42:43 -04:00
|
|
|
(call-next-method))
|
|
|
|
|
|
2018-06-24 20:42:55 -04:00
|
|
|
(defmacro! define-element (name (&rest args) &body body)
|
|
|
|
|
`(defun ,name (&rest ,g!attrs-and-children)
|
2018-06-27 10:01:18 -04:00
|
|
|
(multiple-value-bind (,g!attrs ,g!children)
|
2018-06-24 20:42:55 -04:00
|
|
|
(split-attrs-and-children ,g!attrs-and-children)
|
2018-06-30 17:39:20 -04:00
|
|
|
(let ((,g!element
|
2023-12-21 12:40:05 -05:00
|
|
|
(make-user-element :tag (string-downcase ',name) :attrs ,g!attrs
|
|
|
|
|
:children ,g!children)))
|
2018-06-30 17:39:20 -04:00
|
|
|
(setf (user-element-expander ,g!element)
|
|
|
|
|
(lambda (tag attrs children)
|
|
|
|
|
(declare (ignorable tag attrs children))
|
|
|
|
|
(let ,(mapcar (lambda (arg)
|
|
|
|
|
(list arg `(attr attrs (make-keyword ',arg))))
|
2023-12-21 12:40:05 -05:00
|
|
|
args)
|
2018-06-30 17:39:20 -04:00
|
|
|
(progn ,@body))))
|
|
|
|
|
,g!element))))
|
2018-06-27 09:32:41 -04:00
|
|
|
|
|
|
|
|
(defvar *expand-user-element* t)
|
|
|
|
|
|
|
|
|
|
(defmethod print-object ((element user-element) stream)
|
|
|
|
|
(if *expand-user-element*
|
2018-06-30 17:32:09 -04:00
|
|
|
(print-object (user-element-expand-to element) stream)
|
2018-06-27 09:32:41 -04:00
|
|
|
(call-next-method)))
|
|
|
|
|
|
2018-07-28 11:07:49 -04:00
|
|
|
(defun html-element-p (x)
|
|
|
|
|
(and (symbolp x) (not (keywordp x)) (gethash (collect-name-as-keyword x) *builtin-elements*)))
|
|
|
|
|
|
2018-06-27 09:32:41 -04:00
|
|
|
(defmacro h (&body body)
|
|
|
|
|
`(progn
|
|
|
|
|
,@(tree-leaves
|
|
|
|
|
body
|
2018-07-28 11:07:49 -04:00
|
|
|
(html-element-p x)
|
2024-02-03 21:12:38 +09:00
|
|
|
(find-symbol (string-upcase x) :piccolo))))
|
2018-06-30 21:57:33 -04:00
|
|
|
|
|
|
|
|
(defmethod element-string ((element element))
|
|
|
|
|
(with-output-to-string (s)
|
|
|
|
|
(write element :stream s)))
|
|
|
|
|
|
|
|
|
|
(defmethod elem-str ((element element))
|
|
|
|
|
(with-output-to-string (s)
|
|
|
|
|
(write element :stream s :pretty nil)))
|
