hsx/src/element.lisp

157 lines
4.5 KiB
Common Lisp
Raw Normal View History

2024-05-25 21:48:35 +09:00
(defpackage #:hsx/element
2024-05-25 12:00:39 +09:00
(:use #:cl)
2024-10-04 08:44:27 +09:00
(:import-from #:str
#:collapse-whitespaces)
2024-10-03 09:54:43 +09:00
(:import-from #:hsx/utils
2025-03-28 12:47:37 +09:00
#:escape-html-text-content
#:escape-html-attribute)
(:export #:element
#:tag
#:html-tag
2024-06-09 21:03:21 +09:00
#:self-closing-tag
#:fragment
2025-03-28 12:47:37 +09:00
#:raw-fragment
#:component
#:create-element
2024-05-28 20:15:29 +09:00
#:element-type
2024-05-25 12:00:39 +09:00
#:element-props
2024-05-26 00:57:06 +09:00
#:element-children
#:expand-component
2024-06-01 22:49:15 +09:00
#:render-to-string))
2024-05-25 21:48:35 +09:00
(in-package #:hsx/element)
2024-05-25 12:00:39 +09:00
2024-10-03 10:25:30 +09:00
;;; tag group definitions
2025-03-28 12:47:37 +09:00
(deftype self-closing-tag-sym ()
'(member
:area :base :br :col :embed :hr :img :input
:link :meta :param :source :track :wbr))
2024-10-03 10:25:30 +09:00
2024-05-26 23:29:30 +09:00
;;;; class definitions
2024-05-25 12:00:39 +09:00
(defclass element ()
2024-05-26 01:29:58 +09:00
((type
:reader element-type
:initarg :type)
2024-05-25 12:00:39 +09:00
(props
:reader element-props
2024-05-26 00:57:06 +09:00
:initarg :props)
(children
:reader element-children
:initarg :children)))
2024-05-25 12:00:39 +09:00
2024-05-28 20:48:39 +09:00
(defclass tag (element) ())
2024-05-26 23:29:30 +09:00
2024-05-28 20:48:39 +09:00
(defclass html-tag (tag) ())
2024-05-26 23:29:30 +09:00
2024-06-09 21:03:21 +09:00
(defclass self-closing-tag (tag) ())
2024-05-29 12:46:57 +09:00
(defclass fragment (tag) ())
2024-05-26 23:29:30 +09:00
2025-03-28 12:47:37 +09:00
(defclass raw-fragment (fragment) ())
2024-05-28 20:48:39 +09:00
(defclass component (element) ())
2024-05-26 23:29:30 +09:00
;;;; factory
2024-05-26 23:29:30 +09:00
(defun create-element (type props children)
(make-instance
2024-06-05 08:22:14 +09:00
(cond ((functionp type) 'component)
((eq type :<>) 'fragment)
2025-03-28 12:47:37 +09:00
((eq type :raw!) 'raw-fragment)
2024-06-05 08:22:14 +09:00
((eq type :html) 'html-tag)
2025-03-28 12:47:37 +09:00
((typep type 'self-closing-tag-sym) 'self-closing-tag)
2024-06-05 08:22:14 +09:00
((keywordp type) 'tag)
(t (error "element-type must be a keyword or a function.")))
:type type
:props props
:children (flatten children)))
2024-06-08 14:29:00 +09:00
2024-05-25 12:00:39 +09:00
(defun flatten (x)
(labels ((rec (x acc)
(cond ((null x) acc)
((atom x) (cons x acc))
(t (rec
(car x)
(rec (cdr x) acc))))))
(rec x nil)))
2024-05-26 13:57:51 +09:00
2024-05-26 23:29:30 +09:00
;;;; methods
2024-06-11 19:18:47 +09:00
(defgeneric render-to-string (element &key pretty)
(:documentation "Render an HSX element to a string."))
2024-06-01 22:49:15 +09:00
(defmethod render-to-string ((element element) &key pretty)
2024-05-29 12:57:51 +09:00
(with-output-to-string (stream)
2024-06-01 22:49:15 +09:00
(write element :stream stream :pretty pretty)))
2024-05-29 12:57:51 +09:00
(defmethod print-object ((element tag) stream)
2024-06-09 21:28:18 +09:00
(let ((type (render-type element))
(props (render-props element))
(children (render-children element)))
(if children
(format stream
(if (or (rest children)
2025-03-28 12:47:37 +09:00
(typep (first children) '(and element (not fragment))))
2024-06-09 21:28:18 +09:00
"~@<<~a~a>~2I~:@_~<~@{~a~^~:@_~}~:>~0I~:@_</~a>~:>"
"~@<<~a~a>~2I~:_~<~a~^~:@_~:>~0I~_</~a>~:>")
type
props
children
type)
(format stream "<~a~a></~a>" type props type))))
2024-06-09 21:03:21 +09:00
(defmethod print-object ((element self-closing-tag) stream)
2024-06-09 21:28:18 +09:00
(format stream "<~a~a>" (render-type element) (render-props element)))
2024-05-26 23:29:30 +09:00
2024-06-09 21:14:03 +09:00
(defmethod print-object ((element html-tag) stream)
(format stream "<!DOCTYPE html>~%")
(call-next-method))
(defmethod print-object ((element fragment) stream)
2024-06-09 21:28:18 +09:00
(let ((children (render-children element)))
2024-06-09 21:14:03 +09:00
(if children
(format stream
(if (rest children)
"~<~@{~a~^~:@_~}~:>"
"~<~a~:>")
2024-06-09 21:28:18 +09:00
children))))
2024-06-09 21:14:03 +09:00
(defmethod print-object ((element component) stream)
(print-object (expand-component element) stream))
2024-06-09 21:28:18 +09:00
(defmethod render-type ((element tag))
(string-downcase (element-type element)))
(defmethod render-props ((element tag))
2024-10-04 08:44:27 +09:00
(collapse-whitespaces
2024-10-03 09:54:43 +09:00
(with-output-to-string (stream)
(loop
:for (key value) :on (element-props element) :by #'cddr
:do (let ((key-str (string-downcase key)))
(if (typep value 'boolean)
(format stream
"~@[ ~a~]"
(and value key-str))
(format stream
" ~a=\"~a\""
key-str
(escape-html-attribute value))))))))
2024-05-26 23:29:30 +09:00
2024-06-09 21:03:21 +09:00
(defmethod render-children ((element tag))
2024-06-07 10:07:37 +09:00
(mapcar (lambda (child)
2024-06-09 21:03:21 +09:00
(if (stringp child)
2024-06-07 10:07:37 +09:00
(escape-html-text-content child)
child))
2024-06-09 21:03:21 +09:00
(element-children element)))
2025-03-28 12:47:37 +09:00
(defmethod render-children ((element raw-fragment))
2024-06-09 21:03:21 +09:00
(element-children element))
2024-06-07 10:07:37 +09:00
(defmethod expand-component ((element component))
2024-06-09 22:37:51 +09:00
(apply (element-type element) (element-props-with-children element)))
2024-05-27 16:03:23 +09:00
2024-06-09 22:37:51 +09:00
(defmethod element-props-with-children ((element component))
(with-slots (props children) element
(append props (and children (list :children children)))))