parent
a096d0be7b
commit
88d87a5920
3 changed files with 47 additions and 18 deletions
|
@ -21,6 +21,9 @@
|
||||||
;;; exported as |time|, |map|
|
;;; exported as |time|, |map|
|
||||||
:html
|
:html
|
||||||
|
|
||||||
|
;;; fragment
|
||||||
|
:<>
|
||||||
|
|
||||||
;;; user defined elements
|
;;; user defined elements
|
||||||
:define-element
|
:define-element
|
||||||
:*expand-user-element*
|
:*expand-user-element*
|
||||||
|
|
|
@ -18,6 +18,9 @@
|
||||||
((expand-to :initarg :expander
|
((expand-to :initarg :expander
|
||||||
:accessor user-element-expander)))
|
:accessor user-element-expander)))
|
||||||
|
|
||||||
|
(defclass fragment (element)
|
||||||
|
())
|
||||||
|
|
||||||
(defun make-builtin-element (&key tag attrs children)
|
(defun make-builtin-element (&key tag attrs children)
|
||||||
(make-instance 'builtin-element
|
(make-instance 'builtin-element
|
||||||
:tag tag
|
:tag tag
|
||||||
|
@ -44,6 +47,12 @@
|
||||||
(element-attrs element)
|
(element-attrs element)
|
||||||
(element-children element)))
|
(element-children element)))
|
||||||
|
|
||||||
|
(defun make-fragment (&key children)
|
||||||
|
(make-instance 'fragment
|
||||||
|
:tag 'fragment
|
||||||
|
:attrs (make-attrs :alist nil)
|
||||||
|
:children (escape-children children)))
|
||||||
|
|
||||||
(defstruct (attrs (:constructor %make-attrs))
|
(defstruct (attrs (:constructor %make-attrs))
|
||||||
alist)
|
alist)
|
||||||
|
|
||||||
|
@ -164,21 +173,22 @@ When given :ASCII and :ATTR, it's possible to insert html text as a children, e.
|
||||||
(defmacro! define-element (name (&rest args) &body body)
|
(defmacro! define-element (name (&rest args) &body body)
|
||||||
(let ((%name (alexandria:symbolicate '% name)))
|
(let ((%name (alexandria:symbolicate '% name)))
|
||||||
`(progn
|
`(progn
|
||||||
(defun ,%name (&rest ,g!attrs-and-children)
|
(defun ,%name (&rest attrs-and-children)
|
||||||
(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 attrs-and-children)
|
||||||
(let ((,g!element
|
(make-user-element
|
||||||
(make-user-element :tag (string-downcase ',name)
|
:tag (string-downcase ',name)
|
||||||
:attrs ,g!attrs
|
:attrs ,g!attrs
|
||||||
:children ,g!children)))
|
:children ,g!children
|
||||||
(setf (user-element-expander ,g!element)
|
:expander (lambda (tag attrs ,g!exp-children)
|
||||||
(lambda (tag attrs children)
|
(declare (ignorable tag attrs ,g!exp-children))
|
||||||
(declare (ignorable tag attrs children))
|
(let ((children (and ,g!exp-children
|
||||||
|
(make-fragment :children ,g!exp-children))))
|
||||||
|
(declare (ignorable children))
|
||||||
(let ,(mapcar (lambda (arg)
|
(let ,(mapcar (lambda (arg)
|
||||||
(list arg `(attr attrs (make-keyword ',arg))))
|
(list arg `(attr attrs (make-keyword ',arg))))
|
||||||
args)
|
args)
|
||||||
(progn ,@body))))
|
(progn ,@body)))))))
|
||||||
,g!element)))
|
|
||||||
(defmacro ,name (&body attrs-and-children)
|
(defmacro ,name (&body attrs-and-children)
|
||||||
`(,',%name ,@attrs-and-children)))))
|
`(,',%name ,@attrs-and-children)))))
|
||||||
|
|
||||||
|
@ -189,6 +199,19 @@ When given :ASCII and :ATTR, it's possible to insert html text as a children, e.
|
||||||
(print-object (user-element-expand-to element) stream)
|
(print-object (user-element-expand-to element) stream)
|
||||||
(call-next-method)))
|
(call-next-method)))
|
||||||
|
|
||||||
|
(defun %<> (&rest children)
|
||||||
|
(make-fragment :children children))
|
||||||
|
|
||||||
|
(defmacro <> (&body children)
|
||||||
|
`(%<> ,@children))
|
||||||
|
|
||||||
|
(defmethod print-object ((element fragment) stream)
|
||||||
|
(if (element-children element)
|
||||||
|
(format stream (if (rest (element-children element))
|
||||||
|
"~<~@{~a~^~:@_~}~:>"
|
||||||
|
"~<~a~:>")
|
||||||
|
(element-children element))))
|
||||||
|
|
||||||
(defun html-element-p (x)
|
(defun html-element-p (x)
|
||||||
(and (symbolp x) (not (keywordp x)) (gethash (make-keyword x) *builtin-elements*)))
|
(and (symbolp x) (not (keywordp x)) (gethash (make-keyword x) *builtin-elements*)))
|
||||||
|
|
||||||
|
@ -196,7 +219,7 @@ When given :ASCII and :ATTR, it's possible to insert html text as a children, e.
|
||||||
`(progn
|
`(progn
|
||||||
,@(modify-first-leaves
|
,@(modify-first-leaves
|
||||||
body
|
body
|
||||||
(html-element-p x)
|
(or (html-element-p x) (string= x '<>))
|
||||||
(find-symbol (string-upcase x) :piccolo))))
|
(find-symbol (string-upcase x) :piccolo))))
|
||||||
|
|
||||||
(defmethod element-string ((element element))
|
(defmethod element-string ((element element))
|
||||||
|
|
|
@ -261,19 +261,22 @@
|
||||||
|
|
||||||
(is (eql nil (attrs-alist (element-attrs dog3))))
|
(is (eql nil (attrs-alist (element-attrs dog3))))
|
||||||
(is (string= "dog" (second (element-children (user-element-expand-to dog3)))))
|
(is (string= "dog" (second (element-children (user-element-expand-to dog3)))))
|
||||||
(is (string= "dog.png" (attr (first (element-children (user-element-expand-to dog3))) :src)))
|
(is (string= "dog.png" (attr (first (element-children
|
||||||
|
(first (element-children (user-element-expand-to dog3))))) :src)))
|
||||||
(is (string= "dog.png" (attr (first (element-children dog3)) :src)))
|
(is (string= "dog.png" (attr (first (element-children dog3)) :src)))
|
||||||
|
|
||||||
(is (equal '((:id . "dog") (:size . 10)) (attrs-alist (element-attrs dog4))))
|
(is (equal '((:id . "dog") (:size . 10)) (attrs-alist (element-attrs dog4))))
|
||||||
(is (= 10 (attr dog4 :size)))
|
(is (= 10 (attr dog4 :size)))
|
||||||
(is (string= "img" (element-tag (first (element-children dog4)))))
|
(is (string= "img" (element-tag (first (element-children dog4)))))
|
||||||
(is (string= "dog4.png" (attr (first (element-children (user-element-expand-to dog4))) :src)))
|
(is (string= "dog4.png" (attr (first (element-children
|
||||||
|
(first (element-children (user-element-expand-to dog4))))) :src)))
|
||||||
(is (string= "woo" (second (element-children dog4))))
|
(is (string= "woo" (second (element-children dog4))))
|
||||||
|
|
||||||
(setf (attr dog4 :size) 16)
|
(setf (attr dog4 :size) 16)
|
||||||
(is (string= "big-dog" (attr (user-element-expand-to dog4) :class)))
|
(is (string= "big-dog" (attr (user-element-expand-to dog4) :class)))
|
||||||
(setf (element-children dog4) (list dog1 dog2 dog3))
|
(setf (element-children dog4) (list dog1 dog2 dog3))
|
||||||
(is (equal (list dog1 dog2 dog3 "dog") (element-children (user-element-expand-to dog4))))))
|
(is (equal (list dog1 dog2 dog3) (element-children
|
||||||
|
(first (element-children (user-element-expand-to dog4))))))))
|
||||||
|
|
||||||
(test user-element-html-generation
|
(test user-element-html-generation
|
||||||
(LET* ((dog1 (dog))
|
(LET* ((dog1 (dog))
|
||||||
|
|
Loading…
Reference in a new issue