diff options
| -rw-r--r-- | package.lisp | 2 | ||||
| -rw-r--r-- | shtml.asd | 5 | ||||
| -rw-r--r-- | shtml.lisp | 42 |
3 files changed, 49 insertions, 0 deletions
diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..388d21e --- /dev/null +++ b/package.lisp @@ -0,0 +1,2 @@ +(uiop:define-package #:shtml + (:use #:cl)) diff --git a/shtml.asd b/shtml.asd new file mode 100644 index 0000000..37bf2dc --- /dev/null +++ b/shtml.asd @@ -0,0 +1,5 @@ +(asdf:defsystem #:shtml + :serial t + :components + ((:file "package") + (:file "shtml"))) diff --git a/shtml.lisp b/shtml.lisp new file mode 100644 index 0000000..78f8199 --- /dev/null +++ b/shtml.lisp @@ -0,0 +1,42 @@ +(in-package #:shtml) + +(defun trim-flatten-assoc (lst) + (loop :for (i . j) :in lst + :when j :append (list i j))) + +(defun downcase-name (s) + (string-downcase (symbol-name s))) + +(defun separate-keys (lst) + (let (keys body) + (loop :while lst + :if (keywordp (car lst)) + :do (progn + (push (pop lst) keys) + (push (pop lst) keys)) + :else + :do (push (pop lst) body)) + (cons (cons 'list (reverse body)) (reverse keys)))) + +(defmacro define-html (tag &key single attrs) + (let* ((args (gensym)) + (attrs (append (list 'id 'class) attrs)) + (tag-name (downcase-name tag)) + (attrs-and-values (cons 'list + (mapcar (lambda (attr) + (list 'cons (downcase-name attr) attr)) + attrs)))) + (if (eq single nil) + `(defmacro ,tag (&rest ,args) + (let ((body (gensym)) + (parsed-args (separate-keys ,args))) + `((lambda (,body &key ,@',attrs) + (format nil "<~a~{ ~a=~s~}>~{~a~^ ~}</~a>" + ,,tag-name + (trim-flatten-assoc ,',attrs-and-values) + ,body + ,,tag-name)) ,@parsed-args))) + `(defun ,tag (&key ,@attrs) + (format nil "<~a ~{~a=~s~^ ~}>" + ,tag-name + (trim-flatten-assoc ,attrs-and-values)))))) |