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

Format

Browse source
This commit is contained in:
paku 2024-02-05 02:45:48 +09:00
parent 6050602eec
commit 5afef2e895
3 changed files with 72 additions and 60 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

41
src/piccolo.lisp
View file

@ -19,15 +19,23 @@
:accessor user-element-expander))) :accessor user-element-expander)))
(defun make-builtin-element (&key tag attrs children) (defun make-builtin-element (&key tag attrs children)
(make-instance 'builtin-element :tag tag :attrs attrs (make-instance 'builtin-element
:tag tag
:attrs attrs
:children (escape-children children))) :children (escape-children children)))
(defun make-builtin-element-with-prefix (&key tag attrs children prefix) (defun make-builtin-element-with-prefix (&key tag attrs children prefix)
(make-instance 'builtin-element-with-prefix :tag tag :attrs attrs :prefix prefix (make-instance 'builtin-element-with-prefix
:tag tag
:attrs attrs
:prefix prefix
:children (escape-children children))) :children (escape-children children)))
(defun make-user-element (&rest args &key tag attrs children expander) (defun make-user-element (&key tag attrs children expander)
(make-instance 'user-element :tag tag :attrs attrs :expander expander (make-instance 'user-element
:tag tag
:attrs attrs
:expander expander
:children (escape-children children))) :children (escape-children children)))
(defmethod user-element-expand-to ((element user-element)) (defmethod user-element-expand-to ((element user-element))
@ -78,7 +86,8 @@ When given :ASCII and :ATTR, it's possible to insert html text as a children, e.
(defun %html (&rest attrs-and-children) (defun %html (&rest attrs-and-children)
(multiple-value-bind (attrs children) (multiple-value-bind (attrs children)
(split-attrs-and-children attrs-and-children) (split-attrs-and-children attrs-and-children)
(make-builtin-element-with-prefix :tag "html" :attrs attrs (make-builtin-element-with-prefix :tag "html"
:attrs attrs
:children children :children children
:prefix "<!DOCTYPE html>"))) :prefix "<!DOCTYPE html>")))
@ -94,7 +103,8 @@ When given :ASCII and :ATTR, it's possible to insert html text as a children, e.
(multiple-value-bind (attrs children) (multiple-value-bind (attrs children)
(split-attrs-and-children attrs-and-children) (split-attrs-and-children attrs-and-children)
(make-builtin-element :tag (string-downcase (mkstr ',element-name)) (make-builtin-element :tag (string-downcase (mkstr ',element-name))
:attrs attrs :children children))) :attrs attrs
:children children)))
(defmacro ,element-name (&body attrs-and-children) (defmacro ,element-name (&body attrs-and-children)
`(,',%element-name ,@attrs-and-children))))) `(,',%element-name ,@attrs-and-children)))))
@ -108,14 +118,14 @@ When given :ASCII and :ATTR, it's possible to insert html text as a children, e.
(define-and-export-builtin-elements (define-and-export-builtin-elements
a abbr address area article aside audio b base bdi bdo blockquote 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 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)
(defmethod print-object ((attrs attrs) stream) (defmethod print-object ((attrs attrs) stream)
(if (attrs-alist attrs) (if (attrs-alist attrs)
@ -158,7 +168,8 @@ When given :ASCII and :ATTR, it's possible to insert html text as a children, e.
(multiple-value-bind (,g!attrs ,g!children) (multiple-value-bind (,g!attrs ,g!children)
(split-attrs-and-children ,g!attrs-and-children) (split-attrs-and-children ,g!attrs-and-children)
(let ((,g!element (let ((,g!element
(make-user-element :tag (string-downcase ',name) :attrs ,g!attrs (make-user-element :tag (string-downcase ',name)
:attrs ,g!attrs
:children ,g!children))) :children ,g!children)))
(setf (user-element-expander ,g!element) (setf (user-element-expander ,g!element)
(lambda (tag attrs children) (lambda (tag attrs children)

36
src/util.lisp
View file

@ -2,7 +2,7 @@
(defun plist-alist (plist) (defun plist-alist (plist)
(loop for (k v) on plist by #'cddr (loop for (k v) on plist by #'cddr
collect (cons k v))) collect (cons k v)))
(defun alist-plist (alist) (defun alist-plist (alist)
(mapcan (lambda (kv) (mapcan (lambda (kv)
@ -18,21 +18,21 @@
(let ((car-result (tree-leaves%% (car tree) test result)) (let ((car-result (tree-leaves%% (car tree) test result))
(cdr-result (tree-leaves%% (cdr tree) test result))) (cdr-result (tree-leaves%% (cdr tree) test result)))
(if (!expanded-p car-result) (if (!expanded-p car-result)
(append (!expanded-list car-result) cdr-result) (append (!expanded-list car-result) cdr-result)
(cons car-result cdr-result))) (cons car-result cdr-result)))
(if (funcall test tree) (if (funcall test tree)
(funcall result tree) (funcall result tree)
tree)))) tree))))
(defmacro tree-leaves (tree test result) (defmacro tree-leaves (tree test result)
`(tree-leaves%% `(tree-leaves%%
,tree ,tree
(lambda (x) (lambda (x)
(declare (ignorable x)) (declare (ignorable x))
,test) ,test)
(lambda (x) (lambda (x)
(declare (ignorable x)) (declare (ignorable x))
,result))) ,result)))
(defun utf8-html-escape-char-p (char) (defun utf8-html-escape-char-p (char)
(find char "<>&")) (find char "<>&"))
@ -57,8 +57,8 @@
(if (stringp string) (if (stringp string)
(with-output-to-string (s) (with-output-to-string (s)
(loop (loop
for c across string for c across string
do (write (if (funcall test c) (escape-char c) c) :stream s :escape nil))) do (write (if (funcall test c) (escape-char c) c) :stream s :escape nil)))
string)) string))
(defun escape-attrs-alist (alist) (defun escape-attrs-alist (alist)
@ -95,12 +95,12 @@
(append-inline-attrs attrs-and-children)) (append-inline-attrs attrs-and-children))
((keywordp (first attrs-and-children)) ((keywordp (first attrs-and-children))
(loop for thing on attrs-and-children by #'cddr (loop for thing on attrs-and-children by #'cddr
for (k v) = thing for (k v) = thing
when (and (keywordp k) v) when (and (keywordp k) v)
collect (cons k v) into attrs collect (cons k v) into attrs
when (not (keywordp k)) when (not (keywordp k))
return (values (make-attrs :alist attrs) (flatten thing)) return (values (make-attrs :alist attrs) (flatten thing))
finally (return (values (make-attrs :alist attrs) nil)))) finally (return (values (make-attrs :alist attrs) nil))))
(t (t
(values (make-attrs :alist nil) (flatten attrs-and-children))))) (values (make-attrs :alist nil) (flatten attrs-and-children)))))

55
t/piccolo.lisp
View file

@ -16,7 +16,7 @@
(div2 (div "the children text")) (div2 (div "the children text"))
(div3 (div "text 1" "text 2")) (div3 (div "text 1" "text 2"))
(div4 (div (h1 "text 0") "text 01" (div4 (div (h1 "text 0") "text 01"
(list (list "text 3" div2) div3) "text 4"))) (list (list "text 3" div2) div3) "text 4")))
(is (eql nil (attrs-alist (element-attrs div1)))) (is (eql nil (attrs-alist (element-attrs div1))))
(is (eql nil (element-children div1))) (is (eql nil (element-children div1)))
(is (eql nil (attrs-alist (element-attrs div2)))) (is (eql nil (attrs-alist (element-attrs div2))))
@ -158,10 +158,10 @@
(defun new-a () (defun new-a ()
(a *a-attrs* (a *a-attrs*
"child text 1" "child text 1"
"child text 2 <br> &" "child text 2 <br> &"
(a :href "child'<>\".html" "child'<>\"" (string (code-char 128))) (a :href "child'<>\".html" "child'<>\"" (string (code-char 128)))
(string (code-char 128)))) (string (code-char 128))))
(test escape-attr (test escape-attr
(let ((escaped-attrs-alist '((:id . "nothing-to-escape") (let ((escaped-attrs-alist '((:id . "nothing-to-escape")
@ -225,8 +225,8 @@
(define-element cat () (define-element cat ()
(div :id "cat" (div :id "cat"
(img :src "cat.png") (img :src "cat.png")
"I'm a cat")) "I'm a cat"))
(test user-element-simple (test user-element-simple
(let ((cat (cat))) (let ((cat (cat)))
@ -237,11 +237,11 @@
(define-element dog (id size) (define-element dog (id size)
(if (and (realp size) (> size 10)) (if (and (realp size) (> size 10))
(div :id id :class "big-dog" (div :id id :class "big-dog"
children children
"dog") "dog")
(div :id id :class "small-dog" (div :id id :class "small-dog"
children children
"dog"))) "dog")))
(test user-element-with-attrs (test user-element-with-attrs
(let ((dog1 (dog)) (let ((dog1 (dog))
@ -281,10 +281,10 @@
(dog3 (dog (img :src "dog.png"))) (dog3 (dog (img :src "dog.png")))
(dog4 (dog :id "dog" :size 10 (img :src "dog4.png") "woo")) (dog4 (dog :id "dog" :size 10 (img :src "dog4.png") "woo"))
(home (div :id "home" (home (div :id "home"
(cat) (cat)
;; dog4 below is ignored because cat not accepting children ;; dog4 below is ignored because cat not accepting children
(cat dog4) (cat dog4)
(dog :id "doge" (cat))))) (dog :id "doge" (cat)))))
(is (string= "<div class=\"small-dog\">dog</div>" (element-string dog1))) (is (string= "<div class=\"small-dog\">dog</div>" (element-string dog1)))
(is (string= "<div class=\"big-dog\">dog</div>" (element-string dog2))) (is (string= "<div class=\"big-dog\">dog</div>" (element-string dog2)))
(is (string= "<div class=\"small-dog\"> (is (string= "<div class=\"small-dog\">
@ -346,9 +346,9 @@
(define-element duck (id color) (define-element duck (id color)
(h (div :id (format nil "duck~a" id) (h (div :id (format nil "duck~a" id)
:style (format nil "color:~a" color) :style (format nil "color:~a" color)
"ga ga ga" "ga ga ga"
piccolo:children))) piccolo:children)))
(test h-macro (test h-macro
(let ((some-var 3)) (let ((some-var 3))
@ -358,19 +358,20 @@
<div id=\"b\">foo</div> <div id=\"b\">foo</div>
some text some text
</div>" (element-string </div>" (element-string
(h (div :id "a" (h (div :id "a"
(img :href "a.png") (img :href "a.png")
(div (if (> some-var 0) (div (if (> some-var 0)
'(:id "b") '(:id "b")
'(:id "c")) '(:id "c"))
"foo") "foo")
"some text"))))) "some text")))))
(is (string= "<div id=\"duck5\" style=\"color:blue\"> (is (string=
"<div id=\"duck5\" style=\"color:blue\">
ga ga ga ga ga ga
<img href=\"duck.png\"> <img href=\"duck.png\">
</div>" </div>"
(element-string (element-string
(h (duck :id 5 :color "blue" (h (duck :id 5 :color "blue"
(img :href "duck.png")))))))) (img :href "duck.png"))))))))
(run-all-tests) (run-all-tests)