web/dom: render link (<a>) with attributes OK

test/test-web.lisp

@@ -26,6 +26,7 @@
         (core:setup-services)
         (let ((server (core:find-service :server))
               (client (core:find-service :client)))
+          (test-dom)
           (test-server-config server)
           (sleep 0.1)
           (test-fileserver client)
@@ -37,7 +38,7 @@
 (deftest test-dom ()
   (== (dom:render 
         (dom:link '(:href "https://example.com"
-                    :title "Demo" :class '(:demo-link :plain))
+                    :title "Demo" :class (:demo-link :plain))
                   (dom:text "Link to example.com")))
       "<a href=\"https://example.com\" title=\"Demo\" class=\"demo-link plain\">Link to example.com</a>"))
 

util.lisp

@@ -2,7 +2,7 @@
 
 (defpackage :scopes/util
   (:use :common-lisp)
-  (:export #:flatten-str #:to-keyword
+  (:export #:flatten-str #:to-keyword #:to-string
            #:absolute-dir #:check-dir #:ensure-dir #:home-path #:path-from-string
            #:relative-path #:runtime-path #:system-path))
 
@@ -13,6 +13,11 @@
 (defun flatten-str (s &key (with " "))
   (str:join with (str:lines s)))
 
+(defun to-string (k)
+  (if (atom k)
+    (string-downcase k)
+    (str:join " " (mapcar #'string-downcase k))))
+
 (defun to-keyword (s)
   (intern (string-upcase s) :keyword))
 

web/dom.lisp

@@ -2,7 +2,8 @@
 
 (defpackage :scopes/web/dom
   (:use :common-lisp)
-  (:local-nicknames (:alx :alexandria))
+  (:local-nicknames (:util :scopes/util)
+                    (:alx :alexandria))
   (:export #:render #:text
            #:dl #:link))
 
@@ -30,20 +31,36 @@
   `(progn
      (start ,tag ,attrs)
      ,@body
-     (end ,tag t)))
+     (end ,tag)))
+
+(defun put-attrs (plist)
+  (loop for (key val . r) on plist by #'cddr do
+     (put-char #\Space)
+     (when val
+       (put-string (string-downcase key))
+       (when (not (eq val t))
+         (put-string "=\"")
+         (put-string (attr-str key val))
+         (put-char #\")))))
+
+(defun attr-str (key val)
+  (case key 
+    ((:id :class) (util:to-string val))
+    (t (string val))))
 
 (defun start (tag &optional attrs)
   (put-char #\<)
   (put-string tag)
-  ;(put-attrs attrs)
+  (put-attrs attrs)
   (put-char #\>))
 
-(defun end (tag &optional newline)
+(defun end (tag)
   (put-string "</")
   (put-string tag)
-  (put-char #\>)
-  (if newline
-    (put-char #\Newline)))
+  (put-char #\>))
+
+(defun newline ()
+  (put-char #\Newline))
 
 ;;;; tag-specific renderers