-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathcompile.lisp
138 lines (121 loc) · 4.53 KB
/
compile.lisp
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
(in-package #:hextml)
(defclass html-compiler ()
())
(defun compile-html (compiler element)
(html-compile compiler element))
(defgeneric html-compile (compiler element))
(defmethod html-compile ((compiler html-compiler) anything)
(lambda (renderer stream)
(html-render renderer anything stream)))
(defmethod html-compile ((compiler html-compiler) (function function))
(lambda (renderer stream)
(funcall function renderer stream)))
(defmethod html-compile ((compiler html-compiler) (annotation hextml-annotation))
(html-compile compiler (hextml-annotation-target annotation)))
(defmethod html-compile ((compiler html-compiler) (node html-node))
(with-readers ((type html-node-type)
(attributes html-node-attributes)
(children html-node-children))
node
(let ((attributes-generator (make-html-attributes-generator compiler attributes))
(child-generators (mapcar (fmask #'html-compile ? (compiler ?))
children)))
(if child-generators
(lambda (renderer stream)
(format stream "<~A" type)
(funcall attributes-generator renderer stream)
(write-char #\> stream)
(dolist (child-generator child-generators)
(funcall child-generator renderer stream))
(format stream "</~A>" type))
(lambda (renderer stream)
(format stream "<~A" type)
(funcall attributes-generator renderer stream)
(write-string " />" stream))))))
(defmethod html-compile ((compiler html-compiler) (html-id html-id))
(html-compile compiler (html-id-to-string html-id)))
(defmethod html-compile ((compiler html-compiler) (html html-if))
(with-readers ((condition html-if-condition)
(then html-if-then)
(else html-if-else)) html
(let ((compiled-then (if then
(html-compile compiler then)))
(compiled-else (if else
(html-compile compiler else))))
(lambda (renderer stream)
(let ((branch (if (eval-html-if-condition renderer condition)
compiled-then
compiled-else)))
(if branch
(funcall branch renderer stream)))))))
(defmethod html-compile ((compiler html-compiler) (html html-do))
(let ((var (html-do-var html))
(reference (html-do-reference html))
(compiled (html-compile compiler (html-do-html html))))
(lambda (renderer stream)
(dolist (item (resolve-template-env-reference reference
(template-env renderer)))
(funcall compiled
(make-instance 'html-renderer
:template-env
(make-instance 'template-env
:parent (template-env renderer)
:bindings (list (cons var item))))
stream)))))
(defmethod html-compile ((compiler html-compiler) (str string))
(lambda (renderer stream)
(declare (ignore renderer))
(write-string str stream)))
(defmethod html-compile ((compiler html-compiler) (nothing null))
(lambda (&rest whatever)
(declare (ignore whatever))
nil))
(defmethod html-compile ((compiler html-compiler) (list list))
(let ((compiled (mapcar (fmask #'html-compile ? (compiler ?))
list)))
(lambda (renderer stream)
(dolist (compiled compiled)
(funcall compiled renderer stream)))))
(defmethod html-compile ((compiler html-compiler) (uri uri))
(html-compile compiler (princ-to-string uri)))
(defmethod html-compile ((compiler html-compiler) (ref template-env-reference))
(lambda (renderer stream)
(html-render renderer (resolve-template-env-reference ref (template-env renderer))
stream)))
(defun make-html-attributes-generator (compiler attribute-alist)
(let ((compiled
(mapalist (lambda (attribute value)
(let ((attribute attribute))
(if (html-if-p value)
(html-compile compiler
(flet ((bof (branch)
(lif ((html (funcall branch value)))
(list (format nil " ~A=\"" attribute)
html
"\""))))
(make-html-if (html-if-condition value)
(bof #'html-if-then)
(bof #'html-if-else))))
(if (labels ((look (thing)
(etypecase thing
(html-if t)
(list (member-if #'look thing))
(t nil))))
(look value))
(html-compile compiler
(list (format nil " ~A=\"" attribute)
value
"\""))
(etypecase attribute
(string
(let ((compiled-value (html-compile compiler value)))
(lambda (renderer stream)
(format stream " ~A=\"" attribute)
(funcall compiled-value renderer stream)
(write-char #\" stream))))
((eql quote)
(html-compile compiler value)))))))
attribute-alist)))
(lambda (renderer stream)
(dolist (compiled compiled)
(funcall compiled renderer stream)))))