4ec32cc2d2c99eeda2ee4a2e1c4e9bd895d7f35b
[clinton/lisp-on-lines.git] / src / ucw / html-description.lisp
1 (in-package :lisp-on-lines)
2
3 (export '(html-description) (find-package :lisp-on-lines))
4
5 (defvar *escape-html* t)
6
7 (defmethod generic-format ((display lol-ucw:component) string &rest args)
8 (<:as-html (with-output-to-string (stream)
9 (apply #'call-next-method stream string args))))
10
11
12 (define-description html-description ()
13 ())
14
15 (define-description t ()
16 ((css-class :value "lol-description" :activep nil)
17 (dom-id :function (lambda (x)
18 (declare (ignore x))
19 (symbol-name
20 (gensym "DOM-ID-")))
21 :activep nil))
22 (:in-description html-description))
23
24 (define-layered-class html-attribute ()
25 ((css-class :accessor attribute-css-class
26 :initform "lol-attribute")
27 (dom-id :accessor attribute-dom-id :initform nil)
28 (display-empty-label :accessor attribute-display-empty-label-p :initarg :display-empty-label-p :initform t)))
29
30 (define-layered-class standard-attribute
31 :in-layer #.(defining-description 'html-description)
32 (html-attribute)
33 ())
34
35 (define-layered-function display-html-attribute-label (object attribute)
36 (:method (object attribute)
37
38 (let ((label (attribute-label attribute)))
39 (when (or label (attribute-display-empty-label-p attribute))
40 (<:td (<:label
41 :class "lol-attribute-label"
42 (when label
43 (<:as-html
44 (with-output-to-string (*display*)
45 (display-attribute-label attribute)))))))))
46 (:method
47 :in-layer #.(defining-description 'inline)
48 (object attribute)
49 (let ((label (attribute-label attribute)))
50 (when label
51 (<:as-html
52 (with-output-to-string (*display*)
53 (display-attribute-label attribute)))))))
54
55 (define-layered-function display-html-attribute-value (object attribute)
56 (:method (object attribute)
57 (<:td
58 :class "lol-attribute-value"
59 (<:as-html
60 (display-attribute-value attribute))))
61
62 (:method
63 :in-layer #.(defining-description 'inline) (object attribute)
64 (display-attribute-value attribute)))
65
66 (define-layered-function display-html-attribute (object attribute)
67
68 (:method (object attribute)
69 (<:tr
70 :class (attribute-css-class attribute)
71 (when (attribute-dom-id attribute)
72 :id (attribute-dom-id attribute))
73 (display-html-attribute-label object attribute)
74 (display-html-attribute-value object attribute)))
75
76 (:method
77 :in-layer #.(defining-description 'inline)
78 (object attribute)
79 (<:span
80 :class (attribute-css-class attribute)
81 (when (attribute-dom-id attribute)
82 :id (attribute-dom-id attribute))
83 (display-html-attribute-label object attribute)
84 (display-html-attribute-value object attribute))))
85
86 (define-layered-method display-using-description
87 :in-layer #.(defining-description 'html-description)
88 :around ((attribute standard-attribute) display object &rest args)
89 (declare (ignore args))
90 (display-html-attribute object attribute))
91
92
93 (defun capture-description (attribute function)
94 (let ((obj (described-object (attribute-description attribute))))
95 (lambda (&rest args)
96 (dletf (((described-object attribute) obj))
97 (apply function args)))))
98
99 (defun make-attribute-value-writer (attribute)
100 (let ((obj (described-object (attribute-description attribute)))
101 (value (attribute-value attribute)))
102 (lambda (val)
103 (dletf (((described-object attribute) obj))
104 (with-active-descriptions (editable)
105 (unless (and (unbound-slot-value-p value)
106 (equal "" val))
107 (setf (attribute-value attribute)
108 (parse-attribute-value attribute val))))))))
109
110
111 (defmethod html-attribute-value (attribute)
112 (let ((val (attribute-value attribute)))
113 (if (unbound-slot-value-p val)
114 ""
115 val)))
116
117 (defmethod display-html-attribute-editor (attribute editor)
118 (<lol:input :type "text"
119 :reader (html-attribute-value attribute)
120 :writer (make-attribute-value-writer attribute)))
121
122 (defmethod display-html-attribute-editor ((attribute slot-definition-attribute) editor)
123 (call-next-method))
124
125 (defmethod display-html-attribute-editor (attribute (editor password-attribute-editor))
126 (<lol:input :type "password"
127 :reader (html-attribute-value attribute)
128 :writer (make-attribute-value-writer attribute)))
129
130
131 (define-layered-method display-attribute-editor
132 :in-layer #.(defining-description 'html-description) (attribute)
133 (display-html-attribute-editor attribute (attribute-editor attribute)))
134
135
136 (define-layered-method display-html-attribute-value
137 :in-layer #.(defining-description 'editable) (object attribute)
138
139 (<:td
140 :class "lol-attribute-value"
141 (if (attribute-editp attribute)
142 (display-attribute-editor attribute)
143 (call-next-method))))
144
145 (define-layered-function display-html-description (description display object &optional next-method)
146 (:method (description display object &optional (next-method #'display-using-description))
147 (<:style
148 (<:as-html "
149
150
151
152 div.lol-description .lol-attribute-label,
153 div.lol-description .lol-attribute-value {
154 display: block;
155 width: 69%;
156 float: left;
157 margin-bottom: 1em;
158 border:1px solid black;
159
160 }
161 div.lol-description
162 .lol-attribute-label {
163 text-align: right;
164 width: 24%;
165 padding-right: 1em;
166 }
167
168 span.lol-attribute-value .lol-attribute-value (
169 border: 1px solid red;}
170
171
172 div.lol-description
173 br {
174 clear: left;
175 }
176
177 .clear {clear:left}"
178
179 ))
180
181 (with-attributes (css-class dom-id) description
182
183
184 (<:table
185 :class (list (attribute-value css-class) "lol-description" "t")
186 :id (attribute-value dom-id)
187 (funcall next-method)
188 (<:br :class "clear")))))
189
190
191 (define-layered-method display-html-description
192 :in-layer #.(defining-description 'inline) (description display object &optional next-method)
193 (with-attributes (css-class dom-id) description
194 (<:span
195 :class (list (attribute-value css-class) "lol-description")
196 :id (attribute-value dom-id)
197 (funcall next-method))))
198
199
200 (define-display
201 :in-description html-description ((description t)
202 (display lol-ucw:component)
203 object)
204 (display-html-description description display object (lambda ()
205 (call-next-method))))
206
207 (define-layered-method display-html-attribute-value
208 (object (attribute list-attribute))
209 (<:ul
210 (arnesi:dolist* (item (attribute-value attribute))
211 (<:li (apply #'display *display* item (slot-value attribute 'item-args))))))
212
213
214
215
216
217
218
219
220