Commit | Line | Data |
---|---|---|
7733a777 DC |
1 | (in-package :lisp-on-lines) |
2 | ||
e1645f63 | 3 | ;;;; A few layers related to attributes |
2b0fd9c8 DC |
4 | (deflayer omit-nil-attributes) |
5 | ||
6 | (defdisplay :in-layer omit-nil-attributes | |
7 | :around ((attribute standard-attribute) object) | |
8 | (when (attribute-value object attribute) | |
9 | (call-next-method))) | |
10 | ||
e1645f63 | 11 | (deflayer show-attribute-labels) |
2b0fd9c8 | 12 | |
e1645f63 | 13 | (defdisplay |
14 | :in-layer show-attribute-labels | |
e4f96295 | 15 | :around ((attribute standard-attribute) object) |
fb04c0a8 | 16 | (<:label |
e1645f63 | 17 | :class "lol-label" |
18 | (<:as-html (or (label attribute) (attribute.name attribute)) " ")) | |
19 | (<:span | |
20 | :class "lol-attribute" | |
21 | (call-next-method))) | |
22 | ||
23 | (deflayer use-pretty-labels) | |
24 | ||
25 | (define-layered-method label | |
26 | :in-layer use-pretty-labels | |
27 | :around (standard-attribute) | |
28 | (let ((label (call-next-method))) | |
29 | (when label | |
30 | (string-capitalize | |
31 | (substitute #\Space #\- label))))) | |
32 | ||
e4f96295 | 33 | (deflayer inspect-attributes) |
34 | ||
35 | (defdisplay :in-layer inspect-attributes | |
36 | :around ((attribute standard-attribute) object) | |
37 | (call-next-method) | |
38 | (<ucw:a :action (ucw::call-inspector self attribute) | |
39 | :title | |
40 | (strcat "Inspect " | |
41 | (attribute.name attribute) ":" | |
42 | (description.type attribute) ":" | |
43 | (type-of attribute)) | |
44 | (<:as-html "(i)"))) | |
45 | ||
46 | ;;;; Functional attributes | |
47 | (defattribute display-attribute () | |
48 | ((display-arguments | |
49 | :accessor display-arguments | |
50 | :initarg :display | |
51 | :special t | |
52 | :initform nil)) | |
53 | (:type-name display) | |
e1645f63 | 54 | (:documentation "Apply the display function to this object")) |
2b0fd9c8 | 55 | |
e4f96295 | 56 | (defdisplay ((attribute display-attribute) object) |
e1645f63 | 57 | (apply #'display self (attribute-value object attribute) |
e4f96295 | 58 | (display-arguments attribute))) |
2b0fd9c8 | 59 | |
e4f96295 | 60 | (defattribute function-attribute () |
61 | ((function :accessor function-of | |
62 | :initarg :function | |
63 | :initform #'funcall | |
64 | :special t)) | |
65 | (:type-name function) | |
66 | (:documentation "")) | |
2b0fd9c8 | 67 | |
e4f96295 | 68 | (defdisplay ((function function-attribute) object) |
69 | (funcall (function-of function) | |
70 | (attribute-value object function))) | |
2b0fd9c8 | 71 | |
2b0fd9c8 | 72 | |
e4f96295 | 73 | ;;;; Attribute Grouping |
74 | (defattribute attribute-group () | |
9af22ce3 | 75 | () |
a4e6154d | 76 | (:default-properties |
e4f96295 | 77 | :group nil) |
78 | (:type-name group)) | |
e1645f63 | 79 | |
e4f96295 | 80 | (defdisplay ((group attribute-group) object) |
81 | (apply #'display self object | |
82 | :attributes (attributes group) | |
83 | (group group))) | |
e1645f63 | 84 | |
fb04c0a8 | 85 | |
86 | (defattribute select-attribute (display-attribute) | |
87 | () | |
88 | (:default-properties | |
89 | :test 'meta-model::generic-equal | |
90 | :options-getter (constantly nil)) | |
91 | (:type-name select)) | |
92 | ||
93 | (defdisplay ((attribute select-attribute) object) | |
94 | (<ucw:select | |
95 | :accessor (attribute-value object attribute) | |
96 | ||
97 | :test (test attribute) | |
98 | (dolist* (obj (funcall (options-getter attribute) object)) | |
99 | (<ucw:option | |
100 | :value obj | |
101 | (apply #'display* obj (display-arguments attribute)))))) | |
102 | ||
e4f96295 | 103 | ;;;; * Base Types |
e1645f63 | 104 | |
e4f96295 | 105 | (defattribute base-attribute () |
106 | () | |
107 | (:default-properties | |
108 | :default-value "")) | |
e1645f63 | 109 | |
e4f96295 | 110 | (defdisplay ((base base-attribute) object) |
111 | (<:as-html (attribute-value object base))) | |
e1645f63 | 112 | |
fb04c0a8 | 113 | (defattribute base-attribute () |
e4f96295 | 114 | () |
115 | (:in-layer editor) | |
116 | (:default-properties | |
117 | :callback nil | |
118 | :default-value nil | |
fb04c0a8 | 119 | :default-value-predicate #'null |
120 | :dom-id (js:gen-js-name-string :prefix "_ucw_") | |
121 | :input-size nil)) | |
e1645f63 | 122 | |
e4f96295 | 123 | (define-layered-function display-value (attribute value) |
124 | (:method (attribute value) | |
125 | (if (funcall (default-value-predicate attribute) value) | |
126 | (default-value attribute) | |
127 | value))) | |
e1645f63 | 128 | |
129 | (defdisplay | |
e4f96295 | 130 | :in-layer editor ((field base-attribute) object) |
131 | (LET ((value (attribute-value (object field) field))) | |
132 | (<:input | |
133 | :NAME | |
134 | (callback field) | |
135 | :VALUE (escape-as-html (strcat (display-value field value))) | |
136 | :TYPE | |
137 | "text" | |
138 | :ID | |
139 | (DOM-ID FIELD) | |
140 | :SIZE | |
fb04c0a8 | 141 | (INPUT-SIZE FIELD)))) |
e1645f63 | 142 | |
a4e6154d DC |
143 | (defdisplay |
144 | :in-layer editor :around ((string base-attribute) object) | |
e4f96295 | 145 | (dletf (((callback string) |
146 | (or (callback string) | |
147 | (ucw::make-new-callback | |
148 | #'(lambda (val) | |
149 | (setf (attribute-value object string) val))))) | |
e1645f63 | 150 | ((object string) object)) |
a4e6154d | 151 | (call-next-method))) |
2b0fd9c8 | 152 | |
a4e6154d DC |
153 | ;;;; Strings |
154 | ||
e1645f63 | 155 | (defattribute string-attribute (base-attribute) |
a4e6154d | 156 | () |
9af22ce3 DC |
157 | (:type-name string) |
158 | (:default-properties | |
2b0fd9c8 DC |
159 | :escape-html-p t |
160 | :size nil | |
e4f96295 | 161 | :max-length nil |
162 | :default-value "")) | |
9af22ce3 | 163 | |
2b0fd9c8 DC |
164 | (defdisplay :in-layer omit-nil-attributes |
165 | :around ((attribute string-attribute) object) | |
166 | (when (< 0 (length (attribute-value object attribute))) | |
167 | (call-next-method))) | |
168 | ||
2b0fd9c8 | 169 | ;;;; default |
a4e6154d DC |
170 | (defdisplay :in-layer viewer |
171 | ((string string-attribute) object) | |
2b0fd9c8 | 172 | (if (escape-html-p string) |
9af22ce3 DC |
173 | (<:as-html (attribute-value object string)) |
174 | (<:as-is (attribute-value object string)))) | |
175 | ||
176 | ||
2b0fd9c8 DC |
177 | ;;;; editor |
178 | (defattribute string-attribute (base-attribute) | |
179 | () | |
180 | (:in-layer editor) | |
181 | (:default-properties | |
182 | :callback nil)) | |
183 | ||
a4e6154d | 184 | |
2b0fd9c8 DC |
185 | (defattribute string-search-attribute (string-attribute) |
186 | () | |
187 | (:default-properties | |
188 | ;; the func that find search results | |
189 | ||
190 | :search-action #'(lambda () | |
191 | (with-call/cc | |
192 | nil)) | |
193 | ;; when chosing from a list of results, this function selects one. | |
194 | :select-function (constantly t)) | |
195 | (:type-name string-search)) | |
196 | ||
197 | (defdisplay | |
198 | :in-layer editor :after ((search string-search-attribute) object) | |
a4e6154d DC |
199 | (<:input |
200 | :TYPE "submit" | |
201 | :VALUE "search" | |
202 | :ONCLICK | |
203 | (JS:JS-INLINE* | |
204 | `(PROGN | |
205 | (IT.BESE.UCW::SET-ACTION-PARAMETER | |
206 | ,(IT.BESE.UCW::MAKE-NEW-ACTION | |
207 | (IT.BESE.UCW::CONTEXT.CURRENT-FRAME *CONTEXT*) | |
208 | (search-action search))) | |
209 | (RETURN T))))) | |
2b0fd9c8 DC |
210 | |
211 | ;;;; textarea | |
212 | ||
213 | (defattribute text-attribute (string-attribute) | |
a4e6154d DC |
214 | () |
215 | (:type-name text)) | |
2b0fd9c8 DC |
216 | |
217 | (defdisplay :in-layer editor ((string text-attribute) object) | |
218 | (<:textarea | |
e4f96295 | 219 | :id (dom-id string) |
2b0fd9c8 | 220 | :name (callback string) |
a4e6154d | 221 | (or (attribute-value object string) ""))) |
2b0fd9c8 DC |
222 | |
223 | ||
224 | ||
225 | ;;;; WALL-TIME | |
226 | ||
227 | (defattribute wall-time-attribute (string-attribute) | |
228 | () | |
229 | (:type-name clsql-sys:wall-time)) | |
230 | ||
231 | (define-layered-method attribute-value (object (attribute wall-time-attribute)) | |
232 | (let ((date (call-next-method))) | |
233 | (when date (multiple-value-bind (y m d) (clsql:time-ymd date) | |
234 | (format nil "~a/~a/~a" m d y))))) | |
235 | ||
236 | (defdisplay | |
237 | ((time wall-time-attribute) object) | |
238 | (<:as-html (attribute-value object time))) | |
239 | ||
240 | ||
241 | ||
7733a777 | 242 | (defattribute image () |
a4e6154d DC |
243 | () |
244 | (:default-properties | |
245 | :css-class "lol-image" | |
246 | :prefix "images/")) | |
7733a777 | 247 | |
2b0fd9c8 | 248 | (defdisplay ((buttons (eql 'image-editor-buttons)) object) |
60a24293 DC |
249 | (<ucw:a :action (ok component object) |
250 | (<:as-html "select this image"))) | |
251 | ||
2b0fd9c8 | 252 | (defdisplay ((image image) object) |
7733a777 | 253 | (<:img |
a4e6154d | 254 | :class (or (css-class image) "lol-image") |
7733a777 | 255 | :src (arnesi:strcat |
a4e6154d | 256 | (or (prefix image) "images/") |
7733a777 DC |
257 | (escape-as-uri |
258 | (attribute-value object image))))) | |
259 | ||
2b0fd9c8 DC |
260 | (defdisplay |
261 | :in-layer editor ((image image) object) | |
262 | ||
60a24293 | 263 | (<:div |
2b0fd9c8 | 264 | :class "lol-image-thumbnails" |
a4e6154d | 265 | (<:as-html "imagie"))) |
60a24293 | 266 | |
7733a777 DC |
267 | |
268 | ||
269 | ||
270 | ||
271 |