web/dom: clean-up, improvements, ...

This commit is contained in:
Helmut Merz 2024-07-15 19:35:56 +02:00
parent e33a86d031
commit a43de69210
3 changed files with 27 additions and 36 deletions

View file

@ -37,7 +37,7 @@
(deftest test-dom () (deftest test-dom ()
(== (dom:render (== (dom:render
(dom:link '(:href "https://example.com" (dom:element :a '(:href "https://example.com"
:title "Demo" :class (:demo-link :plain)) :title "Demo" :class (:demo-link :plain))
"Link to example.com")) "Link to example.com"))
"<a href=\"https://example.com\" title=\"Demo\" class=\"demo-link plain\">Link to example.com</a>")) "<a href=\"https://example.com\" title=\"Demo\" class=\"demo-link plain\">Link to example.com</a>"))

View file

@ -13,10 +13,11 @@
(defun flatten-str (s &key (with " ")) (defun flatten-str (s &key (with " "))
(str:join with (str:lines s))) (str:join with (str:lines s)))
(defun to-string (k &key (sep " ")) (defun to-string (k &key (sep " ") lower-case)
(let ((pattern (if lower-case "~(~a~)" "~a")))
(if (atom k) (if (atom k)
(format nil "~(~a~)" k) (format nil pattern k)
(str:join sep (mapcar #'(lambda (s) (format nil "~(~a~)" s)) k)))) (str:join sep (mapcar #'(lambda (s) (format nil pattern s)) k)))))
(defun to-keyword (s) (defun to-keyword (s)
(intern (string-upcase s) :keyword)) (intern (string-upcase s) :keyword))

View file

@ -4,8 +4,8 @@
(:use :common-lisp) (:use :common-lisp)
(:local-nicknames (:util :scopes/util) (:local-nicknames (:util :scopes/util)
(:alx :alexandria)) (:alx :alexandria))
(:export #:render (:export #:elem #:element #:render
#:dlist #:dd #:dl #:dt #:link)) #:dlist))
(in-package :scopes/web/dom) (in-package :scopes/web/dom)
@ -18,45 +18,35 @@
(defclass element () (defclass element ()
((tag :reader tag :initarg :tag) ((tag :reader tag :initarg :tag)
(attrs :reader attrs :initarg :attrs) (attrs :reader attrs :initarg :attrs)
(content :reader content :initarg :content))) (body :reader body :initarg :body)))
(defun elem (tag attrs body)
(make-instance 'element :tag (string-downcase tag)
:attrs attrs :body body))
(defun element (tag attrs &rest body)
(elem tag attrs body))
(defmethod print-object ((el element) stream) (defmethod print-object ((el element) stream)
(format stream "<~a ~s>~s" (tag el) (attrs el) (content el))) (format stream "<~a ~s>~s" (tag el) (attrs el) (body el)))
(defmethod put ((el element)) (defmethod put ((el element))
(start (tag el) (attrs el)) (start (tag el) (attrs el))
(dolist (c (content el)) (dolist (c (body el))
(put c)) (put c))
(end (tag el))) (end (tag el)))
(defun elem (tag attrs content) ;;;; elements with specific functionality
(make-instance 'element :tag tag :attrs attrs :content content))
;;;; specific tags / elements
(defun link (attrs &rest body)
(elem "a" attrs body))
(defun dl (attrs &rest body)
(elem "dl" attrs body))
(defun dt (attrs &rest body)
(elem "dt" attrs body))
(defun dd (attrs &rest body)
(elem "dd" attrs body))
;;;; slightly higher-level elements with specific functionality
(defun dlist (attrs plist) (defun dlist (attrs plist)
(apply #'dl attrs (elem :dl attrs
(loop for (key val . r) on plist by #'cddr append (loop for (key val . r) on plist by #'cddr append
(cons (dt nil (string-downcase key)) (dds nil val))))) (cons (element :dt nil (string-downcase key)) (dds nil val)))))
(defun dds (attrs cont) (defun dds (attrs cont)
(if (atom cont) (if (atom cont)
(list (dd attrs cont)) (list (element :dd attrs cont))
(mapcar #'(lambda (x) (dd nil x)) cont))) (mapcar #'(lambda (x) (element :dd nil x)) cont)))
;;;; rendering ;;;; rendering
@ -86,8 +76,8 @@
(defun attr-str (key val) (defun attr-str (key val)
(case key (case key
((:id :class) (util:to-string val)) ((:id :class) (util:to-string val :lower-case t))
(t (string val)))) (t (util:to-string val))))
(defun start (tag &optional attrs) (defun start (tag &optional attrs)
(put-char #\<) (put-char #\<)