Don't walk inner forms of a deftag in with-html

Closes #85.

compile.lisp

@@ -13,6 +13,15 @@
                ((ignore-errors (constantp form env)) form)
                ;; Don't descend into nested with-tag forms.
                ((eql (car form) 'with-tag) form)
+               ;; Don't descend into deftags.
+               ((and (symbolp (car form))
+                     (get (car form) 'deftag)
+                     ;; It could be a deftag, but it might have been
+                     ;; redefined.
+                     (macro-function (car form))
+                     (let ((exp (macroexpand-1 form env)))
+                       (and (eql (car exp) 'with-html)
+                            form))))
                ;; Compile as a tag.
                ((keywordp (car form))
                 (let ((form (pseudotag-expand (car form) (cdr form))))

deftag.lisp

@@ -49,16 +49,19 @@
   (multiple-value-bind (tag decls docstring)
       (parse-body tag :documentation t)
     (with-gensyms (tmp-body)
-      `(defmacro ,name (&body ,tmp-body)
-         ,@(and docstring (list docstring))
-         (multiple-value-bind  (,tmp-body ,attrs-var)
-             (parse-deftag-body ,tmp-body)
-           (destructuring-bind ,(if (symbolp body) `(&rest ,body) body)
-               ,tmp-body
-             ,@decls
-             ;; Bind the keywords to the provided arguments.
-             (destructuring-bind ,(allow-other-keys ll)
-                 ,attrs-var
-               ;; Remove the keywords from the attributes.
-               (let ((,attrs-var (remove-from-plist ,attrs-var ,@(extract-lambda-list-keywords ll))))
-                 (list 'with-html ,@tag)))))))))
+      `(progn
+         (eval-always
+           (setf (get ',name 'deftag) t))
+         (defmacro ,name (&body ,tmp-body)
+           ,@(and docstring (list docstring))
+           (multiple-value-bind  (,tmp-body ,attrs-var)
+               (parse-deftag-body ,tmp-body)
+             (destructuring-bind ,(if (symbolp body) `(&rest ,body) body)
+                 ,tmp-body
+               ,@decls
+               ;; Bind the keywords to the provided arguments.
+               (destructuring-bind ,(allow-other-keys ll)
+                   ,attrs-var
+                 ;; Remove the keywords from the attributes.
+                 (let ((,attrs-var (remove-from-plist ,attrs-var ,@(extract-lambda-list-keywords ll))))
+                   (list 'with-html ,@tag))))))))))

tests.lisp

@@ -473,11 +473,11 @@
 </body>")
        (with-html-string
          (:body
-          (:h* "This is a top level heading")
-          (:p "...")
-          (let ((*html-path* (append *html-path* '(:section))))
-            (:h* "This is a second-level tricked by *HTML-PATH*")
-            (:p "...")))))))
+           (:h* "This is a top level heading")
+           (:p "...")
+           (let ((*html-path* (append *html-path* '(:section))))
+             (:h* "This is a second-level tricked by *HTML-PATH*")
+             (:p "...")))))))
 
 
 (test print-tree
@@ -792,3 +792,29 @@ bar</pre>"
        (with-html-string
          (:div :onclick (ps:ps (alert "Hello"))))
        "<div onclick=alert(&#39;Hello&#39;);></div>")))
+
+(deftag ul* (body attrs &key &allow-other-keys)
+  "<ul> with every form (except <li>) in BODY auto-wrapped into a <li>."
+  `(:ul ,@attrs ,@(loop for form in body
+                        when (and (listp form)
+                                  (eq :li (first form)))
+                          collect form
+                        else
+                          collect `(:li ,form))))
+
+(test with-html-over-deftag
+  (is (equal
+       (with-html-string
+         (ul*
+           "Item 1"
+           "Item 2"
+           (:b "Bold item 3")
+           (:li "Proper <li> item 4")
+           "Item 5"))
+       "<ul>
+ <li>Item 1
+ <li>Item 2
+ <li><b>Bold item 3</b>
+ <li>Proper &lt;li&gt; item 4
+ <li>Item 5
+</ul>")))