Initial Commit

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))))))