1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
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 'style 'lang 'id 'class 'title 'hidden) 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))))))
|
