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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
|
(in-package #:shtml)
(defun trim-flatten-assoc (lst)
(loop :for (i . j) :in lst
:when j :append (list i j)))
(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))))
(eval-when
(:compile-toplevel)
(defun downcase-name (s)
(string-downcase (symbol-name s)))
(defvar *global-attributes*
(list 'style 'lang 'id 'class 'title 'hidden)))
(defmacro define-singleton-tag (tag &rest attrs)
(let* ((attrs (append *global-attributes* attrs))
(tag-name (downcase-name tag))
(attrs-and-values (cons 'list
(mapcar (lambda (attr)
(list 'cons (downcase-name attr) attr))
attrs))))
`(defun ,tag (&key ,@attrs)
(format nil "<~a ~{~a=~s~^ ~}>"
,tag-name
(trim-flatten-assoc ,attrs-and-values)))))
(defmacro define-tag (tag &rest attrs)
(let* ((args (gensym))
(attrs (append *global-attributes* attrs))
(tag-name (downcase-name tag))
(attrs-and-values (cons 'list
(mapcar (lambda (attr)
(list 'cons (downcase-name attr) attr))
attrs))))
`(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)))))
(defmacro define-html-tag ()
(let* ((args (gensym))
(attrs (cons 'xmlns *global-attributes*))
(tag-name "html")
(attrs-and-values (cons 'list
(mapcar (lambda (attr)
(list 'cons (downcase-name attr) attr))
attrs))))
`(defmacro html (&rest ,args)
(let ((body (gensym))
(parsed-args (separate-keys ,args)))
`((lambda (,body &key ,@',attrs)
(format nil "<!DOCTYPE html><~a~{ ~a=~s~}>~{~a~^ ~}</~a>"
,,tag-name
(trim-flatten-assoc ,',attrs-and-values)
,body
,,tag-name)) ,@parsed-args)))))
(define-html-tag)
(define-tag a download href hreflang media ping referrerpolicy rel target type)
(define-tag abbr)
(define-tag address)
(define-singleton-tag area alt coords download href hreflang media referrerpolicy rel shape target type)
(define-tag article)
(define-tag aside)
(define-tag audio autoplay controls loop muted preload src)
(define-tag b)
(define-singleton-tag base href target)
(define-tag blockquote cite)
(define-tag body)
(define-singleton-tag br)
(define-tag button autofocus disabled form formaction formenctype formmethod formnovalidate formtarget name type value)
(define-tag canvas height width)
(define-tag caption)
(define-tag cite)
(define-tag code)
(define-singleton-tag col span)
(define-tag colgroup span)
(define-tag data value)
(define-tag datalist)
(define-tag dd)
(define-tag del cite datetime)
(define-tag details open)
(define-tag div)
(define-tag dl)
(define-tag dt)
(define-tag em)
(define-singleton-tag embed height src type width)
(define-tag fieldset disabled form name)
(define-tag figcaption)
(define-tag figure)
(define-tag footer)
(define-tag form accept-charset action autocomplete enctype method name novalidate rel target)
(define-tag h1)
(define-tag h2)
(define-tag h3)
(define-tag h4)
(define-tag h5)
(define-tag h6)
(define-tag head)
(define-tag head)
(define-tag header)
(define-singleton-tag hr)
(define-tag i)
(define-singleton-tag img alt crossorigin height ismap loading longdesc referrerpolicy sizes src srcset usemap width)
(define-singleton-tag input accept alt autocomplete autofocus checked dirname disabled form formaction formenctype formmethod formnovalidate formtarget height list max maxlength min minlength multiple name pattern placeholder readonly required size src step type value width)
(define-tag ins cite datetime)
(define-tag label for form)
(define-tag legend)
(define-tag li value)
(define-singleton-tag link crossorigin href hreflang media referrerpolicy rel sizes type)
(define-tag main)
(define-tag mark)
(define-singleton-tag meta charset content http_equiv name)
(define-tag nav)
(define-tag noscript)
(define-tag object data form height name type usemap width)
(define-tag ol refersed start type)
(define-tag optgroup disabled label)
(define-tag option disabled label selected value)
(define-tag output for form name)
(define-tag p)
(define-singleton-tag param name value)
(define-tag picture)
(define-tag pre)
(define-tag progress max value)
(define-tag q cite)
(define-tag s)
(define-tag samp)
(define-tag script async crossorigin defer integrity nomodule referrerpolicy src type)
(define-tag section)
(define-tag select autofocus disabled form multiple name requred size)
(define-tag small)
(define-singleton-tag source media sizes src srcset type)
(define-tag span)
(define-tag strong)
(define-tag style media type)
(define-tag sub)
(define-tag summary)
(define-tag sup)
(define-tag svg)
(define-tag table)
(define-tag tbody)
(define-tag td colspan headers rowspan)
(define-tag template)
(define-tag textarea autocomplete autofocus cols dirname disabled form maxlength minlength name placeholder readonly required rows spellcheck wrap)
(define-tag tfoot)
(define-tag th abbr colspan headers rowspan scope)
(define-tag thead)
(define-tag title)
(define-tag tr)
(define-singleton-tag track default kind label src srclang)
(define-tag u)
(define-tag ul)
(define-tag var)
(define-tag video autoplay controls height loop muted poster preload src width)
(define-singleton-tag wbr)
|
