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))
|
|
|
|
|
|
2024-02-04 00:46:53 +09:00
|
|
|
(defun %html (&rest attrs-and-children)
|
2018-06-25 00:42:43 -04:00
|
|
|
(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>")))
|
2024-02-04 00:46:53 +09:00
|
|
|
|
|
|
|
|
(defmacro html (&body attrs-and-children)
|
|
|
|
|
`(%html ,@attrs-and-children))
|
|
|
|
|
|
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)
|
2024-02-03 22:04:19 +09:00
|
|
|
(let ((%element-name (alexandria:symbolicate '% element-name)))
|
|
|
|
|
`(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)))
|
|
|
|
|
(defmacro ,element-name (&body attrs-and-children)
|
|
|
|
|
`(,',%element-name ,@attrs-and-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)
|
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)
|
2024-02-04 19:50:23 +09:00
|
|
|
(format stream " ~{~a=~s~^ ~}" (alist-plist (attrs-alist attrs)))
|
2018-06-24 13:08:30 -04:00
|
|
|
(format stream "")))
|
|
|
|
|
|
2024-02-05 01:47:26 +09:00
|
|
|
(defparameter *self-closing-tags*
|
|
|
|
|
'(area base br col embed hr img input keygen
|
|
|
|
|
link meta param source track wbr))
|
|
|
|
|
|
|
|
|
|
(defun self-closing-p (tag)
|
|
|
|
|
(member (make-symbol (string-upcase tag))
|
|
|
|
|
*self-closing-tags*
|
|
|
|
|
:test #'string=))
|
2023-12-21 12:40:05 -05:00
|
|
|
|
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)
|
2024-02-03 22:37:58 +09:00
|
|
|
(let ((%name (alexandria:symbolicate '% name)))
|
|
|
|
|
`(progn
|
|
|
|
|
(defun ,%name (&rest ,g!attrs-and-children)
|
|
|
|
|
(multiple-value-bind (,g!attrs ,g!children)
|
|
|
|
|
(split-attrs-and-children ,g!attrs-and-children)
|
|
|
|
|
(let ((,g!element
|
|
|
|
|
(make-user-element :tag (string-downcase ',name) :attrs ,g!attrs
|
|
|
|
|
:children ,g!children)))
|
|
|
|
|
(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))))
|
|
|
|
|
args)
|
|
|
|
|
(progn ,@body))))
|
|
|
|
|
,g!element)))
|
|
|
|
|
(defmacro ,name (&body attrs-and-children)
|
|
|
|
|
`(,',%name ,@attrs-and-children)))))
|
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)
|
2024-02-04 19:50:23 +09:00
|
|
|
(and (symbolp x) (not (keywordp x)) (gethash (make-keyword x) *builtin-elements*)))
|
2018-07-28 11:07:49 -04:00
|
|
|
|
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)))
|
