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

define print-object method for element

Browse source
This commit is contained in:
paku 2024-05-26 23:29:30 +09:00
parent c24da9a7e9
commit 9d0a425b49
3 changed files with 119 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

95
src/element.lisp
View file

@ -7,6 +7,8 @@
#:expand)) #:expand))
(in-package #:hsx/element) (in-package #:hsx/element)
;;;; class definitions
(defclass element () (defclass element ()
((type ((type
:reader element-type :reader element-type
@ -18,23 +20,29 @@
:reader element-children :reader element-children
:initarg :children))) :initarg :children)))
(defclass builtin-element (element) ())
(defclass tag-element (builtin-element) ())
(defclass html-tag-element (tag-element) ())
(defclass fragment-element (builtin-element) ())
(defclass component-element (element) ())
;;;; constructor
(defun create-element (type props &rest children) (defun create-element (type props &rest children)
(let ((elm (make-instance 'element (let ((elm (make-instance (cond ((functionp type) 'component-element)
((string= type "<>") 'fragment-element)
((string= type "html") 'html-tag-element)
(t 'tag-element))
:type type :type type
:props props :props props
:children (flatten children)))) :children (flatten children))))
(prog1 elm (create-element-hook elm)
;dry-run to validate props elm))
(expand elm))))
(defmethod expand ((elm element))
(with-accessors ((type element-type)
(props element-props)
(children element-children)) elm
(if (functionp type)
(apply type
(merge-children-into-props props children))
elm)))
(defun flatten (x) (defun flatten (x)
(labels ((rec (x acc) (labels ((rec (x acc)
@ -45,7 +53,68 @@
(rec (cdr x) acc)))))) (rec (cdr x) acc))))))
(rec x nil))) (rec x nil)))
(defmethod create-element-hook ((elm element)))
(defmethod create-element-hook ((elm fragment-element))
(when (element-props elm)
(error "Cannot pass props to fragment.")))
(defmethod create-element-hook ((elm component-element))
;dry-run to validate props
(expand elm))
;;;; methods
(defmethod expand ((elm component-element))
(with-accessors ((type element-type)
(props element-props)
(children element-children)) elm
(apply type (merge-children-into-props props children))))
(defun merge-children-into-props (props children) (defun merge-children-into-props (props children)
(append props (append props
(and children (and children
(list :children children)))) (list :children children))))
(defmethod print-object ((elm tag-element) stream)
(with-accessors ((type element-type)
(props element-props)
(children element-children)) elm
(if children
(format stream (if (rest children)
"~@<<~a~a>~2I~:@_~<~@{~a~^~:@_~}~:>~0I~:@_</~a>~:>"
"~@<<~a~a>~2I~:_~<~a~^~:@_~:>~0I~_</~a>~:>")
type
(props->string props)
children
type)
(format stream "<~a~a></~a>"
type
(props->string props)
type))))
(defun props->string (props)
(with-output-to-string (stream)
(loop
:for (key value) :on props :by #'cddr
:do (format stream (if (typep value 'boolean)
"~@[ ~a~]"
" ~a=~s")
(string-downcase key)
value))))
(defmethod print-object ((elm html-tag-element) stream)
(format stream "<!DOCTYPE html>~%")
(call-next-method))
(defmethod print-object ((elm fragment-element) stream)
(with-accessors ((children element-children)) elm
(if children
(format stream (if (rest children)
"~<~@{~a~^~:@_~}~:>"
"~<~a~:>")
children))))
(defmethod print-object ((elm component-element) stream)
(print-object (expand elm) stream))

61
src/hsx.lisp
View file

@ -9,16 +9,10 @@
#:hsx)) #:hsx))
(in-package #:hsx/hsx) (in-package #:hsx/hsx)
(defun parse-body (body)
(if (keywordp (first body)) ;;;; hsx definitions
(loop :for thing :on body :by #'cddr
:for (k v) := thing (defparameter *builtin-elements* (make-hash-table))
:when (and (keywordp k) v)
:append (list k v) :into props
:when (not (keywordp k))
:return (values props thing)
:finally (return (values props nil)))
(values nil body)))
(defmacro define-builtin-element (name) (defmacro define-builtin-element (name)
`(defmacro ,name (&body body) `(defmacro ,name (&body body)
@ -28,9 +22,7 @@
(list ,@props) (list ,@props)
,@children)))) ,@children))))
(defparameter *builtin-elements* (make-hash-table)) (defmacro define-and-export-builtin-elements (&body names)
(defmacro define-and-export-builtin-elements (&rest names)
`(progn `(progn
,@(mapcan (lambda (name) ,@(mapcan (lambda (name)
(list `(define-builtin-element ,name) (list `(define-builtin-element ,name)
@ -39,15 +31,20 @@
names))) names)))
(define-and-export-builtin-elements (define-and-export-builtin-elements
a abbr address area article aside audio b base bdi bdo blockquote ; tag-elements
a abbr address area article aside audio b base bdi bdo blockquote
body br button canvas caption cite code col colgroup data datalist body br button canvas caption cite code col colgroup data datalist
dd del details dfn dialog div dl dt em embed fieldset figcaption dd del details dfn dialog div dl dt em embed fieldset figcaption
figure footer form h1 h2 h3 h4 h5 h6 head header html hr i iframe figure footer form h1 h2 h3 h4 h5 h6 head header hr i iframe
img input ins kbd label legend li link main |map| mark meta meter nav 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 noscript object ol optgroup option output p param picture pre progress
q rp rt ruby s samp script section select small source span strong 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 style sub summary sup svg table tbody td template textarea tfoot th
thead |time| title tr track u ul var video wbr) thead |time| title tr track u ul var video wbr
; html-tag-element
html
; fragment-element
<>)
(defmacro defcomp (name props &body body) (defmacro defcomp (name props &body body)
(let ((%name (symbolicate '% name))) (let ((%name (symbolicate '% name)))
@ -61,9 +58,26 @@
(list ,@props) (list ,@props)
,@children)))))) ,@children))))))
(defun builtin-element-p (node) (defun parse-body (body)
(and (symbolp node) (if (keywordp (first body))
(gethash (make-keyword node) *builtin-elements*))) (loop :for thing :on body :by #'cddr
:for (k v) := thing
:when (and (keywordp k) v)
:append (list k v) :into props
:when (not (keywordp k))
:return (values props thing)
:finally (return (values props nil)))
(values nil body)))
;;;; hsx macro to find hsx symbols
(defmacro hsx (&body body)
`(progn
,@(modify-first-leaves body
#'builtin-element-p
(lambda (node)
(find-symbol (string node) :hsx/hsx)))))
(defun modify-first-leaves (tree test result) (defun modify-first-leaves (tree test result)
(if tree (if tree
@ -80,9 +94,6 @@
node)) node))
(rest tree))))) (rest tree)))))
(defmacro hsx (&body body) (defun builtin-element-p (node)
`(progn (and (symbolp node)
,@(modify-first-leaves body (gethash (make-keyword node) *builtin-elements*)))
#'builtin-element-p
(lambda (node)
(find-symbol (string node) :hsx/hsx)))))

2
tests/element.lisp
View file

@ -7,7 +7,7 @@
(def-suite element-test) (def-suite element-test)
(in-suite element-test) (in-suite element-test)
(test builtin-element (test tag-element
(let ((elm (create-element "p" (let ((elm (create-element "p"
'(:class "red") '(:class "red")
"Hello," "Hello,"