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)))
(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)))
(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)))
(defun make-user-element (&rest args &key tag attrs children expander)
(make-instance 'user-element :tag tag :attrs attrs :expander expander
(defun make-user-element (&key tag attrs children expander)
(make-instance 'user-element
:tag tag
:attrs attrs
:expander expander
:children (escape-children children)))
(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)
(multiple-value-bind (attrs 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
: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)
(split-attrs-and-children attrs-and-children)
(make-builtin-element :tag (string-downcase (mkstr ',element-name))
:attrs attrs :children children)))
:attrs attrs
:children children)))
(defmacro ,element-name (&body 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
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
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
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)
body br button canvas caption cite code col colgroup data datalist
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
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)
@ -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)
(split-attrs-and-children ,g!attrs-and-children)
(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)))
(setf (user-element-expander ,g!element)
(lambda (tag attrs children)

36
src/util.lisp
View file

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

55
t/piccolo.lisp
View file

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