Commit | Line | Data |
---|---|---|
5071bbe1 DC |
1 | ;;;; -*- lisp -*- |
2 | ||
5dea194e | 3 | (in-package :lisp-on-lines) |
5071bbe1 DC |
4 | |
5 | (defcomponent presentation () | |
6 | ((css-class :accessor css-class :initarg :css-class :initform nil)) | |
7 | (:documentation "The super class of all UCW presentations. | |
8 | ||
9 | A presentation object is a UCW component which knows how to | |
10 | read/write different kinds of data types. | |
11 | ||
12 | There are three major kinds of presentations: | |
13 | ||
14 | 1) object-presentation - Managing a single object. | |
15 | ||
16 | 2) slot-presentation - Managing the single parts (slots) which | |
17 | make up an object. | |
18 | ||
19 | 3) collection-presentation - Managing multiple objects. | |
20 | ||
21 | Presentations are independant of the underlying application | |
22 | specific lisp objects they manage. A presentation can be created | |
23 | once and reused or modified before and aftre it has been used. | |
24 | ||
25 | Presentations fulfill two distinct roles: on the one hand they | |
26 | create, given a lisp object, a grahpical (html) rendering of that | |
27 | object, they also deal with whatever operations the user might | |
28 | wish to perform on that object. | |
29 | ||
30 | * Creating Presentation Objects | |
31 | ||
32 | Presentation objects are created by making an instance of either | |
33 | an object-presentation or a collection-presentation and then | |
34 | filling the slots property of this object.")) | |
35 | ||
36 | (defgeneric present (presentation) | |
37 | (:documentation "Render PRESENTATION (generally called from render-on).")) | |
38 | ||
39 | (defmacro present-object (object &key using presentation) | |
40 | (assert (xor using presentation) | |
41 | (using presentation) | |
42 | "Must specify exactly one of :USING and :PRESENTATION.") | |
43 | (if using | |
44 | (destructuring-bind (type &rest args) | |
45 | (ensure-list using) | |
46 | `(call ',type ,@args 'instance ,object)) | |
47 | (rebinding (presentation) | |
48 | `(progn | |
49 | (setf (slot-value ,presentation 'instance) ,object) | |
50 | (call-component self ,presentation))))) | |
51 | ||
52 | (defmacro present-collection (presentation-type &rest initargs) | |
53 | `(call ',presentation-type ,@initargs)) | |
54 | ||
55 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
56 | ;;;; object-presentation | |
57 | ||
58 | (defcomponent object-presentation (presentation) | |
59 | ((slots :accessor slots :initarg :slots :initform nil) | |
60 | (instance :initform nil :initarg instance :accessor instance)) | |
61 | (:documentation "Presentations for single objects.")) | |
62 | ||
63 | (defmethod render-on ((res response) (o object-presentation)) | |
64 | (unless (slot-value o 'instance) | |
65 | (error "Attempting to render the presentation ~S, but it has no instance object to present." | |
66 | o)) | |
67 | (present o)) | |
68 | ||
69 | (defmethod present ((pres object-presentation)) | |
70 | (<:table :class (css-class pres) | |
71 | (dolist (slot (slots pres)) | |
72 | (<:tr :class "presentation-slot-row" | |
73 | (<:td :class "presentation-slot-label" (<:as-html (label slot))) | |
74 | (<:td :class "presentation-slot-value" (present-slot slot (instance pres))))) | |
75 | (render-options pres (instance pres)))) | |
76 | ||
77 | (defmethod render-options ((pres object-presentation) instance) | |
78 | (declare (ignore instance pres)) | |
79 | #| (<:tr | |
80 | (<:td :colspan 2 :align "center" | |
81 | (<ucw:input :type "submit" :action (ok pres) :value "Ok."))) |# ) | |
82 | ||
83 | (defaction ok ((o object-presentation) &optional (value (slot-value o 'instance))) | |
84 | (answer value)) | |
85 | ||
86 | (defmethod find-slot ((o object-presentation) slot-label) | |
87 | (find slot-label (slots o) :test #'string= :key #'label)) | |
88 | ||
89 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
90 | ;;;; inline objects are extremly similar to object-presentations | |
91 | ;;;; except that we assume they're being edited within the context of | |
92 | ;;;; some other and so don't get their own edit/delete/confirm | |
93 | ;;;; whatever buttons. | |
94 | ||
95 | (defcomponent inline-object-presentation (object-presentation) | |
96 | ()) | |
97 | ||
98 | (defmethod render-options ((pres inline-object-presentation) instance) | |
99 | (declare (ignore instance)) | |
100 | nil) | |
101 | ||
102 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
103 | ;;;; 'one line' objects | |
104 | ||
105 | (defcomponent one-line-presentation (object-presentation) | |
106 | ((before :accessor before :initform "" :initarg :before | |
107 | :documentation "Text to render before rendirng the slots.") | |
108 | (between :accessor between :initform " " :initarg :between | |
109 | :documentation "Text to render between each slot.") | |
110 | (after :accessor after :initform "" :initarg after | |
111 | :documentation "Text to render after all the slots have been rendered."))) | |
112 | ||
113 | (defmethod present ((pres one-line-presentation)) | |
114 | (<:as-is (before pres)) | |
115 | (when (slots pres) | |
116 | (present-slot (first (slots pres)) (instance pres))) | |
117 | (dolist (slot (cdr (slots pres))) | |
118 | (<:as-is (between pres)) | |
119 | (present-slot slot (instance pres))) | |
120 | (<:as-is (after pres))) | |
121 | ||
122 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
123 | ;;;; List | |
124 | ||
125 | (defcomponent list-presentation (presentation) | |
126 | ((slots :accessor slots :initarg :slots) | |
127 | (editablep :accessor editablep :initform t :initarg :editablep) | |
128 | (edit-label :accessor edit-label :initform "Edit") | |
129 | (deleteablep :accessor deleteablep :initform t :initarg :deleteablep) | |
130 | (delete-label :accessor delete-label :initform "Delete") | |
131 | (instances :accessor instances))) | |
132 | ||
133 | (defmethod initialize-instance :after ((l list-presentation) &rest initargs) | |
134 | (declare (ignore initargs)) | |
135 | (setf (instances l) (get-all-instances l))) | |
136 | ||
137 | (defmethod render-on ((res response) (l list-presentation)) | |
138 | (present l)) | |
139 | ||
140 | (defgeneric get-all-instances (listing) | |
141 | (:documentation "Returns all the instances which should be viewable with LISTING. | |
142 | ||
143 | This method is also used by relation-slot-presentations for the same reason.")) | |
144 | ||
145 | (defmethod present ((listing list-presentation)) | |
146 | (<:table :class (css-class listing) | |
147 | (render-list-heading listing) | |
148 | (iterate | |
149 | (for element in (instances listing)) | |
150 | (for index upfrom 0) | |
151 | (render-list-row listing element index)))) | |
152 | ||
153 | (defmethod render-list-heading ((listing list-presentation)) | |
154 | (<:tr :class "presentation-list-heading-row" | |
155 | (<:th "") | |
156 | (dolist (slot (slots listing)) | |
157 | (<:th :class "presentation-list-heading-cell" | |
158 | (<:as-html (label slot)))) | |
159 | (<:th ""))) | |
160 | ||
161 | (defmethod render-list-row ((listing list-presentation) object index) | |
162 | (<:tr :class "item-row" | |
163 | (<:td :class "index-number-cell" | |
164 | (<:i (<:as-html index))) | |
165 | (dolist (slot (slots listing)) | |
166 | (<:td :class "data-cell" (present-slot slot object))) | |
167 | (<:td :align "center" :valign "top" | |
168 | (when (editablep listing) | |
169 | (let ((object object)) | |
170 | (<ucw:input :type "submit" | |
171 | :action (edit-from-listing listing object index) | |
172 | :value (edit-label listing)))) | |
173 | (<:as-is " ") | |
174 | (when (deleteablep listing) | |
175 | (let ((index index)) | |
176 | (<ucw:input :type "submit" | |
177 | :action (delete-from-listing listing object index) | |
178 | :value (delete-label listing))))))) | |
179 | ||
180 | (defgeneric/cc create-from-listing (listing)) | |
181 | ||
182 | (defmethod/cc create-from-listing :after ((l list-presentation)) | |
183 | (setf (instances l) (get-all-instances l))) | |
184 | ||
185 | (defgeneric/cc delete-from-listing (listing item index)) | |
186 | ||
187 | (defmethod/cc delete-from-listing :after ((l list-presentation) item index) | |
188 | (declare (ignore item index)) | |
189 | (setf (instances l) (get-all-instances l))) | |
190 | ||
191 | (defgeneric/cc edit-from-listing (listing item index)) | |
192 | ||
193 | (defmethod/cc edit-from-listing :after ((l list-presentation) item index) | |
194 | (declare (ignore item index)) | |
195 | (setf (instances l) (get-all-instances l))) | |
196 | ||
197 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
198 | ;;;; Searching/Filtering | |
199 | ||
200 | (defcomponent presentation-search (presentation) | |
201 | ((criteria :accessor criteria :initform '()) | |
202 | (search-presentation :accessor search-presentation :initarg :search-presentation | |
203 | :documentation "The presentation object | |
204 | used in determining what the possible | |
205 | search options are.") | |
206 | (list-presentation :accessor list-presentation :initarg :list-presentation | |
207 | :documentation "The presentation object used when showing the results."))) | |
208 | ||
209 | (defgeneric applicable-criteria (presentation) | |
210 | (:method-combination nconc)) | |
211 | ||
212 | (defmethod applicable-criteria nconc ((search presentation-search)) | |
213 | (let ((criteria '())) | |
214 | (dolist (slot (slots (search-presentation search))) | |
215 | (setf criteria (append criteria (applicable-criteria slot)))) | |
216 | (cons (make-instance 'negated-criteria :presentation search) | |
217 | criteria))) | |
218 | ||
219 | (defcomponent criteria () | |
220 | ((presentation :accessor presentation :initarg :presentation))) | |
221 | ||
222 | (defaction add-criteria ((search presentation-search) (criteria criteria)) | |
223 | (push criteria (criteria search))) | |
224 | ||
225 | (defaction drop-criteria ((search presentation-search) (criteria criteria)) | |
226 | (setf (criteria search) (delete criteria (criteria search)))) | |
227 | ||
228 | (defgeneric apply-criteria (criteria instance) | |
229 | (:method-combination and)) | |
230 | ||
231 | (defmethod valid-instances ((search presentation-search)) | |
232 | (let ((valid '())) | |
233 | (dolist (i (get-all-instances search)) | |
234 | (block apply-criteria | |
235 | (dolist (criteria (criteria search)) | |
236 | (unless (apply-criteria criteria i) | |
237 | (return-from apply-criteria nil))) | |
238 | (push i valid))) | |
239 | valid)) | |
240 | ||
241 | (defcomponent search-results-list (list-presentation) | |
242 | ((search-presentation :accessor search-presentation))) | |
243 | ||
244 | (defmethod render-on ((res response) (s presentation-search)) | |
245 | (<:p "Results:") | |
246 | (let ((listing (list-presentation s))) | |
247 | (<:table | |
248 | (<:tr :class "presentation-list-heading-row" | |
249 | (<:th "") | |
250 | (dolist (slot (slots (list-presentation s))) | |
251 | (<:th :class "presentation-list-heading-cell" | |
252 | (<:as-html (label slot)))) | |
253 | (<:th "")) | |
254 | (loop | |
255 | for object in (valid-instances s) | |
256 | for index upfrom 0 | |
257 | do (<:tr :class "item-row" | |
258 | (<:td :class "index-number-cell" (<:i (<:as-html index))) | |
259 | (dolist (slot (slots (list-presentation s))) | |
260 | (<:td :class "data-cell" (present-slot slot object))) | |
261 | (<:td :align "center" :valign "top" | |
262 | (when (editablep listing) | |
263 | (let ((object object)) | |
264 | (<ucw:input :type "submit" | |
265 | :action (edit-from-search s object index) | |
266 | :value (edit-label listing)))) | |
267 | (<:as-is " ") | |
268 | (when (deleteablep listing) | |
269 | (let ((index index)) | |
270 | (<ucw:input :type "submit" | |
271 | :action (delete-from-search s object index) | |
272 | :value (delete-label listing))))))))) | |
273 | (<:p "Search Criteria:") | |
274 | (<:ul | |
275 | (render-criteria res s) | |
276 | (<:li (<ucw:input :type "submit" :action (refresh-component s) | |
277 | :value "update")))) | |
278 | ||
279 | (defmethod render-criteria ((res response) (s presentation-search)) | |
280 | (<:ul | |
281 | (dolist (c (criteria s)) | |
282 | (<:li (render-on res c) | |
283 | (let ((c c)) | |
284 | (<ucw:input :action (drop-criteria s c) :type "submit" :value "eliminate")))) | |
285 | (let ((new-criteria nil)) | |
286 | (<:li "Add Criteria: " | |
287 | (<ucw:select :accessor new-criteria | |
288 | (dolist (criteria (applicable-criteria s)) | |
289 | (<ucw:option :value criteria (<:as-html (label criteria))))) | |
290 | (<ucw:input :type "submit" :action (add-criteria s new-criteria) | |
291 | :value "add"))))) | |
292 | ||
293 | (defgeneric/cc edit-from-search (search object index)) | |
294 | ||
295 | (defgeneric/cc delete-from-search (search object index)) | |
296 | ||
297 | ;;;; meta criteria | |
298 | ||
299 | (defcomponent negated-criteria (criteria) | |
300 | ((criteria :accessor criteria :initform nil))) | |
301 | ||
302 | (defmethod label ((n negated-criteria)) "Not:") | |
303 | ||
304 | (defmethod render-on ((res response) (n negated-criteria)) | |
305 | (<:p "Not: " | |
306 | (when (criteria n) | |
307 | (render-on res (criteria n)))) | |
308 | (let ((new-criteria nil)) | |
309 | (<:p "Set Criteria: " | |
310 | (<ucw:select :accessor new-criteria | |
311 | (dolist (criteria (applicable-criteria (presentation n))) | |
312 | (<ucw:option :value criteria (<:as-html (label criteria))))) | |
313 | (<ucw:input :type "submit" :action (setf (criteria n) new-criteria) | |
314 | :value "add")))) | |
315 | ||
316 | (defmethod apply-criteria and ((n negated-criteria) instance) | |
317 | (if (criteria n) | |
318 | (not (apply-criteria (criteria n) instance)) | |
319 | t)) | |
320 | ||
321 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
322 | ;;;; Slot presentations | |
323 | ||
324 | (defcomponent slot-presentation (presentation) | |
325 | ((label :accessor label :initarg :label) | |
326 | (label-plural :accessor label-plural :initarg :label-plural) | |
327 | (getter :accessor getter :initarg :getter | |
328 | :documentation "A function used for getting the | |
329 | current value of the object. It will be passed the | |
330 | objcet and must return the current value.") | |
331 | (setter :accessor setter :initarg :setter | |
332 | :documentation "A function used for updatig the value of | |
333 | the underlying object. It will be passed the new | |
334 | value and the object (in that order).") | |
335 | (editablep :accessor editablep :initarg :editablep :initform t) | |
336 | (print-object-label))) | |
337 | ||
338 | (defmethod print-object ((s slot-presentation) stream) | |
339 | (if *print-readably* | |
340 | (call-next-method) | |
341 | (print-unreadable-object (s stream :type t :identity t) | |
342 | (princ (label s) stream) | |
343 | (princ " (" stream) | |
344 | (princ (slot-value s 'print-object-label) stream) | |
345 | (princ ")" stream)))) | |
346 | ||
347 | (defgeneric present-slot (slot instance)) | |
348 | ||
349 | (defmethod initialize-instance :after ((presentation slot-presentation) | |
350 | &key slot-name getter setter &allow-other-keys) | |
351 | (if slot-name | |
352 | (setf (slot-value presentation 'print-object-label) slot-name) | |
353 | (setf (slot-value presentation 'print-object-label) getter)) | |
354 | (when slot-name | |
355 | (assert (not (or getter setter)) | |
356 | (slot-name getter setter) | |
357 | "Can't specify :GETTER and/or :SETTER alnog with :SLOT-NAME.") | |
358 | (setf (getter presentation) (lambda (object) | |
359 | (when (slot-boundp object slot-name) | |
360 | (slot-value object slot-name))) | |
361 | (setter presentation) (lambda (value object) | |
362 | (setf (slot-value object slot-name) value))))) | |
363 | ||
364 | (defvar *presentation-slot-type-mapping* (make-hash-table :test 'eql)) | |
365 | ||
366 | (defun register-slot-type-mapping (name class-name) | |
367 | (setf (gethash name *presentation-slot-type-mapping*) class-name)) | |
368 | ||
369 | (defmacro defslot-presentation (name supers slots &rest options) | |
370 | `(progn | |
371 | (defcomponent ,name ,(or supers `(slot-presentation)) | |
372 | ,slots | |
373 | ,@(remove :type-name options :key #'car)) | |
374 | ,(let ((type-name (assoc :type-name options))) | |
375 | (when type-name | |
376 | `(register-slot-type-mapping ',(second type-name) ',name))) | |
377 | ',name)) | |
378 | ||
379 | (defgeneric presentation-slot-value (slot instance) | |
380 | (:method ((slot slot-presentation) instance) | |
381 | (funcall (getter slot) instance))) | |
382 | ||
383 | (defgeneric (setf presentation-slot-value) (value slot instance) | |
384 | (:method (value (slot slot-presentation) instance) | |
385 | (funcall (setter slot) value instance))) | |
386 | ||
387 | (defmethod applicable-criteria nconc ((s slot-presentation)) | |
388 | nil) | |
389 | ||
390 | (defmacro criteria-for-slot-presentation (slot &body criteria-clauses) | |
391 | (rebinding (slot) | |
392 | `(list | |
393 | ,@(mapcar (lambda (criteria-clause) | |
394 | (let ((criteria-clause (ensure-list criteria-clause))) | |
395 | `(make-instance ',(first criteria-clause) | |
396 | ,@(cdr criteria-clause) | |
397 | :presentation ,slot))) | |
398 | criteria-clauses)))) | |
399 | ||
400 | (defmacro defslot-critera (class-name supers slots &key label apply-criteria) | |
401 | (with-unique-names (obj instance) | |
402 | (list | |
403 | 'progn | |
404 | `(defcomponent ,class-name ,supers ,slots) | |
405 | (when label | |
406 | `(defmethod label ((,obj ,class-name)) | |
407 | (format nil ,label (label (presentation ,obj))))) | |
408 | ||
409 | (when apply-criteria | |
410 | `(defmethod apply-criteria and ((,obj ,class-name) ,instance) | |
411 | (funcall ,apply-criteria | |
412 | ,obj | |
413 | ,instance | |
414 | (presentation-slot-value (presentation ,obj) ,instance)))) | |
415 | `(quote ,class-name)))) | |
416 | ||
417 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
418 | ;;;; Boolean | |
419 | ||
420 | (defslot-presentation boolean-slot-presentation () | |
421 | () | |
422 | (:type-name boolean)) | |
423 | ||
424 | (defmethod present-slot ((slot boolean-slot-presentation) instance) | |
53927015 DC |
425 | (if (editablep slot) |
426 | (let ((callback (ucw::make-new-callback | |
427 | (lambda (val) | |
428 | ||
429 | (if (listp val) | |
430 | (setf (presentation-slot-value slot instance) t) | |
431 | (setf (presentation-slot-value slot instance) nil)))))) | |
432 | (<:input :type "hidden" :name callback :value "DEFAULT") | |
433 | (<:input :type "checkbox" | |
434 | :name callback | |
435 | :checked (slot-value instance (slot-name slot)))) | |
436 | (<:as-html | |
437 | (if (presentation-slot-value slot instance) | |
438 | "YES" | |
439 | "NO")))) | |
5071bbe1 DC |
440 | |
441 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
442 | ;;;; strings | |
443 | ||
444 | (defslot-presentation string-slot-presentation () | |
445 | ((max-length :accessor max-length :initarg :max-length :initform nil) | |
446 | (size :accessor size :initarg :size :initform nil)) | |
447 | (:type-name string)) | |
448 | ||
449 | (defmethod present-slot ((slot string-slot-presentation) instance) | |
450 | (if (editablep slot) | |
451 | (<ucw:input :type "text" | |
452 | :accessor (presentation-slot-value slot instance) | |
453 | :size (or (size slot) | |
454 | (if (string= "" (presentation-slot-value slot instance)) | |
455 | (size slot) | |
456 | (+ 3 (length (presentation-slot-value slot instance))))) | |
457 | :maxlength (max-length slot)) | |
458 | (<:as-html (presentation-slot-value slot instance)))) | |
459 | ||
460 | ;;;; Critera | |
461 | ||
462 | (defmethod applicable-criteria nconc ((s string-slot-presentation)) | |
463 | (criteria-for-slot-presentation s | |
464 | string-starts-with | |
465 | string-contains | |
466 | string-ends-with)) | |
467 | ||
468 | (defcomponent string-criteria (criteria) | |
469 | ((search-text :accessor search-text :initform nil))) | |
470 | ||
471 | (defmethod render-on ((res response) (criteria string-criteria)) | |
472 | (<:as-html (label criteria) " ") | |
473 | (<ucw:input :type "text" :accessor (search-text criteria) :size 10)) | |
474 | ||
475 | (defslot-critera string-contains (string-criteria) | |
476 | () | |
477 | :label "~A contains:" | |
478 | :apply-criteria (lambda (criteria instance slot-value) | |
479 | (declare (ignore instance)) | |
480 | (and (<= (length (search-text criteria)) (length slot-value)) | |
481 | (search (search-text criteria) slot-value :test #'char-equal)))) | |
482 | ||
483 | (defslot-critera string-starts-with (string-contains) | |
484 | () | |
485 | :label "~A starts with:" | |
486 | :apply-criteria (lambda (criteria instance slot-value) | |
487 | (declare (ignore instance)) | |
488 | (and (<= (length (search-text criteria)) (length slot-value)) | |
489 | (= 0 (or (search (search-text criteria) slot-value | |
490 | :test #'char-equal) | |
491 | -1))))) | |
492 | ||
493 | (defslot-critera string-ends-with (string-contains) | |
494 | () | |
495 | :label "~A ends with:" | |
496 | :apply-criteria (lambda (criteria instance slot-value) | |
497 | (declare (ignore instance)) | |
498 | (and (<= (length (search-text criteria)) (length slot-value)) | |
499 | (= (- (length slot-value) (length (search-text criteria))) | |
500 | (or (search (search-text criteria) slot-value | |
501 | :from-end t | |
502 | :test #'char-equal) | |
503 | -1))))) | |
504 | ||
505 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
506 | ;;;; numbers | |
507 | ||
508 | (defslot-presentation number-slot-presentation () | |
509 | ((min-value :accessor min-value :initarg :min-value :initform nil) | |
510 | (max-value :accessor max-value :initarg :max-value :initform nil))) | |
511 | ||
512 | (defcomponent number-criteria (criteria) | |
513 | ((number-input :accessor number-input :initform nil))) | |
514 | ||
515 | (defmethod applicable-criteria nconc ((s number-slot-presentation)) | |
516 | (criteria-for-slot-presentation s | |
517 | number-less-than | |
518 | number-greater-than | |
519 | number-equal-to)) | |
520 | ||
521 | (defmacro defnumber-criteria (name &key label render-on-prefix apply-criteria) | |
522 | `(progn | |
523 | (defslot-critera ,name (number-criteria) | |
524 | () | |
525 | :label ,label | |
526 | :apply-criteria (lambda (criteria instance slot-value) | |
527 | (declare (ignore instance)) | |
528 | (if (numberp slot-value) | |
529 | (if (number-input criteria) | |
530 | (funcall ,apply-criteria slot-value (number-input criteria)) | |
531 | t) | |
532 | nil))) | |
533 | ||
534 | (defmethod render-on ((res response) (obj ,name)) | |
535 | (<:as-html (format nil ,render-on-prefix (label (presentation obj)))) | |
536 | (<ucw:input :type "text" | |
537 | :reader (or (number-input obj) "") | |
538 | :writer (lambda (v) | |
539 | (unless (string= "" v) | |
540 | (let ((n (parse-float v))) | |
541 | (when n | |
542 | (setf (number-input obj) n))))))))) | |
543 | ||
544 | (defnumber-criteria number-equal-to | |
545 | :apply-criteria (lambda (slot-value number-input) | |
546 | (= slot-value number-input)) | |
547 | :label "~A is equal to:" | |
548 | :render-on-prefix "~A = ") | |
549 | ||
550 | (defnumber-criteria number-less-than | |
551 | :apply-criteria (lambda (slot-value number-input) | |
552 | (< slot-value number-input)) | |
553 | :label "~A is less than:" | |
554 | :render-on-prefix "~A < ") | |
555 | ||
556 | (defnumber-criteria number-greater-than | |
557 | :apply-criteria (lambda (slot-value number-input) | |
558 | (> slot-value number-input)) | |
559 | :label "~A is greater than:" | |
560 | :render-on-prefix "~A > ") | |
561 | ||
562 | ||
563 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
564 | ;;;; Integers | |
565 | ||
566 | (defslot-presentation integer-slot-presentation (number-slot-presentation) | |
567 | () | |
568 | (:type-name integer)) | |
569 | ||
570 | (defmethod presentation-slot-value ((slot integer-slot-presentation) instance) | |
571 | (declare (ignore instance)) | |
572 | (or (call-next-method) "")) | |
573 | ||
574 | (defmethod (setf presentation-slot-value) ((value string) (slot integer-slot-presentation) instance) | |
575 | (unless (string= "" value) | |
576 | (let ((i (parse-integer value :junk-allowed t))) | |
577 | (when i | |
487243db | 578 | (setf (presentation-slot-value slot instance) i))))) |
5071bbe1 DC |
579 | |
580 | (defmethod present-slot ((slot integer-slot-presentation) instance) | |
581 | (if (editablep slot) | |
582 | (<ucw:input :type "text" | |
583 | :accessor (presentation-slot-value slot instance)) | |
584 | (<:as-html (presentation-slot-value slot instance)))) | |
585 | ||
586 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
587 | ;;;; Reals | |
588 | ||
589 | (defcomponent real-slot-presentation (number-slot-presentation) | |
590 | ()) | |
591 | ||
592 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
593 | ;;;; Currency (double precision reals) | |
594 | ||
595 | (defslot-presentation currency-slot-presentation (real-slot-presentation) | |
bf12489a | 596 | ((as-money-p :accessor as-money-p :initarg :as-money-p :initform nil)) |
5071bbe1 DC |
597 | (:type-name currency)) |
598 | ||
599 | (defmethod (setf presentation-slot-value) ((value string) (c currency-slot-presentation) instance) | |
600 | (let ((*read-eval* nil)) | |
601 | (unless (string= "" value) | |
602 | (let ((value (read-from-string value))) | |
603 | (when (numberp value) | |
604 | (setf (presentation-slot-value c instance) value)))))) | |
605 | ||
606 | (defmethod present-slot ((currency currency-slot-presentation) instance) | |
607 | (if (editablep currency) | |
608 | (<ucw:input :type "text" :size 10 | |
609 | :accessor (presentation-slot-value currency instance)) | |
bf12489a DC |
610 | (<:as-html (format nil (if (as-money-p currency) |
611 | "$~$" | |
612 | "~D") | |
613 | (presentation-slot-value currency instance)) ))) | |
5071bbe1 DC |
614 | |
615 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
616 | ;;;; dates and times | |
617 | ||
618 | (defslot-presentation timestamp-slot-presentation (slot-presentation) | |
619 | () | |
620 | (:type-name timestamp)) | |
621 | ||
622 | (defmacro deftimestamp-slot-accessor (accessor time-accessor nth-value make-time-arg) | |
623 | (let ((accessor-name (intern (strcat '#:timestamp-slot- accessor)))) | |
624 | `(progn | |
625 | (defgeneric ,accessor-name (slot instance)) | |
626 | (defgeneric (setf ,accessor-name) (value slot instance)) | |
627 | (defmethod ,accessor-name ((slot timestamp-slot-presentation) instance) | |
628 | (when (presentation-slot-value slot instance) | |
629 | (nth-value ,nth-value (,time-accessor (presentation-slot-value slot instance))))) | |
630 | (defmethod (setf ,accessor-name) ((value integer) (slot timestamp-slot-presentation) instance) | |
631 | (if (presentation-slot-value slot instance) | |
632 | (setf (presentation-slot-value slot instance) | |
633 | (make-time ,make-time-arg value :defaults (presentation-slot-value slot instance))) | |
634 | (setf (presentation-slot-value slot instance) (make-time ,make-time-arg value)))) | |
635 | (defmethod (setf ,accessor-name) ((value string) (slot timestamp-slot-presentation) instance) | |
636 | (setf (,accessor-name slot instance) | |
637 | (if (string= "" value) | |
638 | nil | |
639 | (parse-integer value)))) | |
640 | (defmethod (setf ,accessor-name) ((value null) (slot timestamp-slot-presentation) instance) | |
641 | (setf (presentation-slot-value slot instance) nil))))) | |
642 | ||
643 | (deftimestamp-slot-accessor second time-hms 2 :second) | |
644 | (deftimestamp-slot-accessor minute time-hms 1 :minute) | |
645 | (deftimestamp-slot-accessor hour time-hms 0 :hour) | |
646 | (deftimestamp-slot-accessor year time-ymd 0 :year) | |
647 | (deftimestamp-slot-accessor month time-ymd 1 :month) | |
648 | (deftimestamp-slot-accessor day time-ymd 2 :day) | |
649 | ||
650 | (defslot-presentation ymd-slot-presentation (timestamp-slot-presentation) | |
651 | () | |
652 | (:type-name date)) | |
653 | ||
654 | (defmethod present-slot ((slot ymd-slot-presentation) instance) | |
655 | (if (editablep slot) | |
656 | (<:progn | |
657 | (<ucw:input :class (css-class slot) :type "text" :size 2 | |
658 | :accessor (timestamp-slot-day slot instance)) | |
659 | "/" | |
660 | (<ucw:input :class (css-class slot) :type "text" :size 2 | |
661 | :accessor (timestamp-slot-month slot instance)) | |
662 | "/" | |
663 | (<ucw:input :class (css-class slot) :type "text" :size 4 | |
664 | :accessor (timestamp-slot-year slot instance))) | |
665 | (if (presentation-slot-value slot instance) | |
666 | (<:progn | |
667 | (<:as-html (timestamp-slot-day slot instance)) | |
668 | "/" | |
669 | (<:as-html (timestamp-slot-month slot instance)) | |
670 | "/" | |
671 | (<:as-html (timestamp-slot-year slot instance))) | |
672 | (<:as-html "---")))) | |
673 | ||
674 | (defmethod applicable-criteria nconc ((slot ymd-slot-presentation)) | |
675 | (criteria-for-slot-presentation slot | |
676 | date-before-criteria)) | |
677 | ||
678 | (defslot-critera date-before-criteria (criteria) | |
679 | ((target :accessor target)) | |
680 | :label "Date Before:") | |
681 | ||
682 | (defmethod render-on ((res response) (dbc date-before-criteria)) | |
683 | (<:as-html "Date Before: ")) | |
684 | ||
685 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
686 | ;;;; Relations | |
687 | ||
688 | (defcomponent relation-slot-presentation (slot-presentation) | |
689 | ((presentation :accessor presentation | |
690 | :initarg :presentation | |
691 | :documentation "The class of presentation | |
692 | objects used to fill the options of a select | |
693 | tag.") | |
694 | (search-presentation :accessor search-presentation | |
695 | :initarg :search-presentation | |
696 | :initform nil) | |
697 | (allow-nil-p :accessor allow-nil-p | |
698 | :initarg :allow-nil-p | |
699 | :initform t | |
700 | :documentation "Can this relation not exist."))) | |
701 | ||
702 | (defmethod presentation ((slot relation-slot-presentation)) | |
703 | (with-slots (presentation) | |
704 | slot | |
705 | (if (or (symbolp presentation) | |
706 | (consp presentation)) | |
707 | (setf presentation (apply #'make-instance (ensure-list presentation))) | |
708 | presentation))) | |
709 | ||
710 | (defgeneric get-foreign-instances (pres instance)) | |
711 | ||
712 | (defcomponent relation-criteria (criteria presentation-search) | |
713 | ((criteria :accessor criteria :initform '()))) | |
714 | ||
715 | (defmethod search-presentation ((criteria relation-criteria)) | |
716 | (or (search-presentation (presentation criteria)) | |
717 | (presentation (presentation criteria)))) | |
718 | ||
719 | ;;;; One-Of | |
720 | ||
721 | (defslot-presentation one-of-presentation (relation-slot-presentation) | |
722 | ((none-label :initarg :none-label :accessor none-label | |
723 | :initform "none")) | |
724 | (:type-name one-of)) | |
725 | ||
726 | (defmethod present-slot ((slot one-of-presentation) instance) | |
727 | (if (editablep slot) | |
728 | (<ucw:select :accessor (presentation-slot-value slot instance) | |
729 | (when (allow-nil-p slot) | |
730 | (<ucw:option :value nil (<:as-html (none-label slot)))) | |
731 | (dolist (option (get-foreign-instances (presentation slot) instance)) | |
732 | (setf (instance (presentation slot)) option) | |
733 | (<ucw:option :value option (present (presentation slot))))) | |
734 | (if (presentation-slot-value slot instance) | |
735 | (progn | |
736 | (setf (instance (presentation slot)) (presentation-slot-value slot instance)) | |
737 | (present (presentation slot))) | |
738 | (<:as-html "--")))) | |
739 | ||
740 | (defmethod applicable-criteria nconc ((slot one-of-presentation)) | |
741 | (criteria-for-slot-presentation slot | |
742 | one-of-criteria | |
743 | one-of-not-null)) | |
744 | ||
745 | (defslot-critera one-of-criteria (relation-criteria) | |
746 | ()) | |
747 | ||
748 | (defmethod label ((ooc one-of-criteria)) | |
749 | (strcat (label (presentation ooc)) " with:")) | |
750 | ||
751 | (defmethod render-on ((res response) (ooc one-of-criteria)) | |
752 | (<:as-html (label (presentation ooc)) " with:") | |
753 | (render-criteria res ooc)) | |
754 | ||
755 | (defmethod apply-criteria and ((ooc one-of-criteria) instance) | |
756 | (let ((nested-instance (presentation-slot-value (presentation ooc) instance)) | |
757 | (criteria (criteria ooc))) | |
758 | (if criteria | |
759 | (if nested-instance | |
760 | (dolist (c (criteria ooc) t) | |
761 | (unless (apply-criteria c nested-instance) | |
762 | (return-from apply-criteria nil))) | |
763 | nil) | |
764 | t))) | |
765 | ||
766 | (defslot-critera one-of-not-null (criteria) | |
767 | ()) | |
768 | ||
769 | (defmethod label ((oonn one-of-not-null)) | |
770 | (strcat (label (presentation oonn)) " exists.")) | |
771 | ||
772 | (defmethod apply-criteria and ((oonn one-of-not-null) instance) | |
773 | (not (null (presentation-slot-value (presentation oonn) instance)))) | |
774 | ||
775 | (defmethod render-on ((res response) (oonn one-of-not-null)) | |
776 | (<:as-html (label (presentation oonn)) " exists.")) | |
777 | ||
778 | ;;;; Some-Of | |
779 | ||
780 | (defslot-presentation some-of-presentation (relation-slot-presentation) | |
781 | () | |
782 | (:type-name some-of)) | |
783 | ||
784 | (defmethod present-slot ((slot some-of-presentation) instance) | |
785 | (<:ul | |
786 | (if (presentation-slot-value slot instance) | |
787 | (loop | |
788 | for option in (presentation-slot-value slot instance) | |
789 | for index upfrom 0 | |
790 | do (let ((option option) ;; loop changes the values, it does | |
791 | ;; not create fresh bindings | |
792 | (index index)) | |
793 | (<:li | |
794 | (<:table | |
795 | (<:tr | |
796 | (<:td (setf (instance (presentation slot)) option) | |
797 | (present (presentation slot))) | |
798 | (when (editablep slot) | |
799 | (<:td :align "left" :valign "top" | |
800 | (<ucw:input :type "submit" | |
801 | :action (delete-element slot instance option index) | |
802 | :value (concatenate 'string "Delete " (label slot)))))))))) | |
803 | (<:li "None.")) | |
804 | (render-add-new-item slot instance))) | |
805 | ||
806 | (defmethod render-add-new-item ((slot some-of-presentation) instance) | |
807 | (let ((new-object nil) | |
808 | (foreign-instances (get-foreign-instances (presentation slot) instance))) | |
809 | (when (and foreign-instances (editablep slot)) | |
810 | (<:li "Add: " | |
811 | (<ucw:select :accessor new-object | |
812 | (dolist (option foreign-instances) | |
813 | (setf (instance (presentation slot)) option) | |
814 | (<ucw:option :value option (present (presentation slot))))) | |
815 | (<ucw:input :type "submit" | |
816 | :action (add-element slot instance new-object) | |
817 | :value "Add"))))) | |
818 | ||
819 | (defaction add-element ((some-of some-of-presentation) instance item) | |
820 | (push item (presentation-slot-value some-of instance))) | |
821 | ||
822 | (defaction delete-element ((some-of some-of-presentation) instance item index) | |
823 | (let ((nth (nth index (presentation-slot-value some-of instance)))) | |
824 | (unless (eq nth item) | |
825 | (error "Attempting to delete the ~Dth item, which should be ~S, but the ~Dth item is actually ~S." | |
826 | index item index nth)) | |
827 | (setf (presentation-slot-value some-of instance) | |
828 | (iterate | |
829 | (for element in (presentation-slot-value some-of instance)) | |
830 | (for i upfrom 0) | |
831 | (unless (= index i) | |
832 | (collect element)))))) | |
833 | ||
834 | (defmethod applicable-criteria nconc ((slot some-of-presentation)) | |
835 | (criteria-for-slot-presentation slot | |
836 | some-of-any | |
837 | some-of-all)) | |
838 | ||
839 | (defslot-critera some-of-criteria (relation-criteria) | |
840 | ()) | |
841 | ||
842 | (defmethod render-on ((res response) (soa some-of-criteria)) | |
843 | (<:as-html (label soa)) | |
844 | (render-criteria res soa)) | |
845 | ||
846 | (defmacro defsome-of-criteria (name supers slots &key label apply-criteria) | |
847 | (with-unique-names (obj) | |
848 | `(progn | |
849 | (defslot-critera ,name ,supers ,slots) | |
850 | (defmethod label ((,obj ,name)) | |
851 | (format nil ,label (label (presentation ,obj)))) | |
852 | (defmethod apply-criteria and ((,obj ,name) instance) | |
853 | (let ((nested-instances (presentation-slot-value (presentation ,obj) instance)) | |
854 | (criteria (criteria ,obj))) | |
855 | (if criteria | |
856 | (if nested-instances | |
857 | (funcall ,apply-criteria (criteria ,obj) nested-instances) | |
858 | nil) | |
859 | t)))))) | |
860 | ||
861 | (defsome-of-criteria some-of-any (some-of-criteria) | |
862 | () | |
863 | :label "Any ~A with:" | |
864 | :apply-criteria (lambda (criteria nested-instances) | |
865 | ;; return T if any nested-instance meets all of criteria | |
866 | (some (lambda (instance) | |
867 | (every (lambda (criteria) | |
868 | (apply-criteria criteria instance)) | |
869 | criteria)) | |
870 | nested-instances))) | |
871 | ||
872 | (defsome-of-criteria some-of-all (some-of-criteria) | |
873 | () | |
874 | :label "All ~A with:" | |
875 | :apply-criteria (lambda (criteria nested-instances) | |
876 | ;; return T only if every nested-instances meets | |
877 | ;; all of our criteria | |
878 | (every (lambda (instance) | |
879 | (every (lambda (criteria) | |
880 | (apply-criteria criteria instance)) | |
881 | criteria)) | |
882 | nested-instances))) | |
883 | ||
884 | ;;;; An-Object | |
885 | ||
886 | (defslot-presentation an-object-presentation (one-of-presentation) | |
887 | () | |
888 | (:type-name an-object)) | |
889 | ||
890 | (defmethod present-slot ((slot an-object-presentation) instance) | |
891 | (if (presentation-slot-value slot instance) | |
892 | (progn | |
893 | (setf (instance (presentation slot)) (presentation-slot-value slot instance)) | |
894 | (present (presentation slot)) | |
895 | (<ucw:input :type "submit" :action (delete-an-object slot instance) | |
896 | :value (concatenate 'string "Delete " (label slot)))) | |
897 | (<ucw:input :type "submit" :action (create-an-object slot instance) :value "Create"))) | |
898 | ||
899 | (defaction delete-an-object ((slot an-object-presentation) instance) | |
900 | (setf (presentation-slot-value slot instance) nil)) | |
901 | ||
902 | (defaction create-an-object ((slot an-object-presentation) instance) | |
903 | (let ((obj (make-new-instance (presentation slot) instance))) | |
904 | (format t "Setting (presentation-slot-value ~S ~S) to ~S.~%" slot instance obj) | |
905 | (setf (presentation-slot-value slot instance) obj))) | |
906 | ||
907 | ;;;; Some-Objects | |
908 | ||
909 | (defslot-presentation some-objects-presentation (some-of-presentation) | |
910 | () | |
911 | (:type-name some-objects)) | |
912 | ||
913 | (defmethod render-add-new-item ((slot some-objects-presentation) instance) | |
914 | (when (editablep slot) | |
915 | (<:li (<ucw:input :type "submit" | |
916 | :action (add-an-object slot instance) | |
917 | :value "Add new object.")))) | |
918 | ||
919 | (defgeneric make-new-instance (presentation instance) | |
920 | (:documentation "Create an new instance suitable for | |
921 | PRESENTATION which will be added to INSTANCE (according to | |
922 | PRESENTATION).")) | |
923 | ||
924 | (defaction add-an-object ((slot some-objects-presentation) instance) | |
925 | (push (make-new-instance (presentation slot) instance) (presentation-slot-value slot instance))) | |
926 | ||
927 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
928 | ;;;; Convience macros/functions | |
929 | ||
930 | (defmacro slot-presentations (&rest slot-specs) | |
931 | `(list ,@(mapcar (lambda (slot) | |
932 | (let ((class-name (gethash (car slot) *presentation-slot-type-mapping*))) | |
933 | (if class-name | |
934 | `(make-instance ',class-name ,@(cdr slot)) | |
935 | (error "Unknown slot type ~S." (car slot))))) | |
936 | slot-specs))) | |
937 | ||
938 | (defmacro defpresentation (name supers slots &rest default-initargs) | |
939 | `(defcomponent ,name ,supers | |
940 | () | |
941 | (:default-initargs | |
942 | ,@(when slots `(:slots (slot-presentations ,@slots))) | |
943 | ,@default-initargs))) | |
944 |