paku/hsx
1
0
Fork 0
Code Issues Pull requests Projects Releases 1 Packages Wiki Activity Actions

Add subclasses of tag

Browse source
This commit is contained in:
paku 2024-06-09 21:03:21 +09:00
parent 83e495b1cb
commit f770e371b9
3 changed files with 26 additions and 20 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
hsx-test.asd
View file

@ -11,4 +11,4 @@
(#:hsx-test . #:hsx-test/hsx) (#:hsx-test . #:hsx-test/hsx)
(#:escaper-test . #:hsx-test/escaper) (#:escaper-test . #:hsx-test/escaper)
(#:group-test . #:hsx-test/group)) (#:group-test . #:hsx-test/group))
:num-checks 42) :num-checks 44)

42
src/element.lisp
View file

@ -9,6 +9,8 @@
(:export #:element (:export #:element
#:tag #:tag
#:html-tag #:html-tag
#:self-closing-tag
#:non-escaping-tag
#:fragment #:fragment
#:component #:component
#:create-element #:create-element
@ -36,6 +38,10 @@
(defclass html-tag (tag) ()) (defclass html-tag (tag) ())
(defclass self-closing-tag (tag) ())
(defclass non-escaping-tag (tag) ())
(defclass fragment (tag) ()) (defclass fragment (tag) ())
(defclass component (element) ()) (defclass component (element) ())
@ -47,6 +53,8 @@
(cond ((functionp type) 'component) (cond ((functionp type) 'component)
((eq type :<>) 'fragment) ((eq type :<>) 'fragment)
((eq type :html) 'html-tag) ((eq type :html) 'html-tag)
((self-closing-tag-p type) 'self-closing-tag)
((non-escaping-tag-p type) 'non-escaping-tag)
((keywordp type) 'tag) ((keywordp type) 'tag)
(t (error "element-type must be a keyword or a function."))) (t (error "element-type must be a keyword or a function.")))
:type type :type type
@ -69,9 +77,7 @@
(write element :stream stream :pretty pretty))) (write element :stream stream :pretty pretty)))
(defmethod print-object ((element tag) stream) (defmethod print-object ((element tag) stream)
(with-accessors ((type element-type) (with-slots (type props children) element
(props element-props)
(children element-children)) element
(let ((type-str (string-downcase type)) (let ((type-str (string-downcase type))
(props-str (render-props props))) (props-str (render-props props)))
(if children (if children
@ -82,15 +88,13 @@
"~@<<~a~a>~2I~:_~<~a~^~:@_~:>~0I~_</~a>~:>") "~@<<~a~a>~2I~:_~<~a~^~:@_~:>~0I~_</~a>~:>")
type-str type-str
props-str props-str
(escape-children type children) (render-children element)
type-str) type-str)
(format stream (format stream "<~a~a></~a>" type-str props-str type-str)))))
(if (self-closing-tag-p type)
"<~a~a>" (defmethod print-object ((element self-closing-tag) stream)
"<~a~a></~a>") (with-slots (type props) element
type-str (format stream "<~a~a>" (string-downcase type) (render-props props))))
props-str
type-str)))))
(defun render-props (props) (defun render-props (props)
(with-output-to-string (stream) (with-output-to-string (stream)
@ -106,20 +110,22 @@
key-str key-str
(escape-html-attribute value))))))) (escape-html-attribute value)))))))
(defun escape-children (type children) (defmethod render-children ((element tag))
(mapcar (lambda (child) (mapcar (lambda (child)
(if (and (not (non-escaping-tag-p type)) (if (stringp child)
(stringp child))
(escape-html-text-content child) (escape-html-text-content child)
child)) child))
children)) (element-children element)))
(defmethod render-children ((element non-escaping-tag))
(element-children element))
(defmethod print-object ((element html-tag) stream) (defmethod print-object ((element html-tag) stream)
(format stream "<!DOCTYPE html>~%") (format stream "<!DOCTYPE html>~%")
(call-next-method)) (call-next-method))
(defmethod print-object ((element fragment) stream) (defmethod print-object ((element fragment) stream)
(with-accessors ((children element-children)) element (with-slots (children) element
(if children (if children
(format stream (format stream
(if (rest children) (if (rest children)
@ -131,9 +137,7 @@
(print-object (expand-component element) stream)) (print-object (expand-component element) stream))
(defmethod expand-component ((element component)) (defmethod expand-component ((element component))
(with-accessors ((type element-type) (with-slots (type props children) element
(props element-props)
(children element-children)) element
(apply type (merge-children-into-props props children)))) (apply type (merge-children-into-props props children))))
(defun merge-children-into-props (props children) (defun merge-children-into-props (props children)

2
tests/element.lisp
View file

@ -15,6 +15,8 @@
(test element-class (test element-class
(is (typep (create-element :div nil nil) 'tag)) (is (typep (create-element :div nil nil) 'tag))
(is (typep (create-element :html nil nil) 'html-tag)) (is (typep (create-element :html nil nil) 'html-tag))
(is (typep (create-element :img nil nil) 'self-closing-tag))
(is (typep (create-element :style nil nil) 'non-escaping-tag))
(is (typep (create-element :<> nil nil) 'fragment)) (is (typep (create-element :<> nil nil) 'fragment))
(is (typep (create-element (lambda ()) nil nil) 'component)) (is (typep (create-element (lambda ()) nil nil) 'component))
(signals error (create-element "div" nil nil))) (signals error (create-element "div" nil nil)))