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) | |
5dea194e | 425 | (<ucw:input :type "checkbox" :accessor (presentation-slot-value slot instance))) |
5071bbe1 DC |
426 | |
427 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
428 | ;;;; strings | |
429 | ||
430 | (defslot-presentation string-slot-presentation () | |
431 | ((max-length :accessor max-length :initarg :max-length :initform nil) | |
432 | (size :accessor size :initarg :size :initform nil)) | |
433 | (:type-name string)) | |
434 | ||
435 | (defmethod present-slot ((slot string-slot-presentation) instance) | |
436 | (if (editablep slot) | |
437 | (<ucw:input :type "text" | |
438 | :accessor (presentation-slot-value slot instance) | |
439 | :size (or (size slot) | |
440 | (if (string= "" (presentation-slot-value slot instance)) | |
441 | (size slot) | |
442 | (+ 3 (length (presentation-slot-value slot instance))))) | |
443 | :maxlength (max-length slot)) | |
444 | (<:as-html (presentation-slot-value slot instance)))) | |
445 | ||
446 | ;;;; Critera | |
447 | ||
448 | (defmethod applicable-criteria nconc ((s string-slot-presentation)) | |
449 | (criteria-for-slot-presentation s | |
450 | string-starts-with | |
451 | string-contains | |
452 | string-ends-with)) | |
453 | ||
454 | (defcomponent string-criteria (criteria) | |
455 | ((search-text :accessor search-text :initform nil))) | |
456 | ||
457 | (defmethod render-on ((res response) (criteria string-criteria)) | |
458 | (<:as-html (label criteria) " ") | |
459 | (<ucw:input :type "text" :accessor (search-text criteria) :size 10)) | |
460 | ||
461 | (defslot-critera string-contains (string-criteria) | |
462 | () | |
463 | :label "~A contains:" | |
464 | :apply-criteria (lambda (criteria instance slot-value) | |
465 | (declare (ignore instance)) | |
466 | (and (<= (length (search-text criteria)) (length slot-value)) | |
467 | (search (search-text criteria) slot-value :test #'char-equal)))) | |
468 | ||
469 | (defslot-critera string-starts-with (string-contains) | |
470 | () | |
471 | :label "~A starts with:" | |
472 | :apply-criteria (lambda (criteria instance slot-value) | |
473 | (declare (ignore instance)) | |
474 | (and (<= (length (search-text criteria)) (length slot-value)) | |
475 | (= 0 (or (search (search-text criteria) slot-value | |
476 | :test #'char-equal) | |
477 | -1))))) | |
478 | ||
479 | (defslot-critera string-ends-with (string-contains) | |
480 | () | |
481 | :label "~A ends with:" | |
482 | :apply-criteria (lambda (criteria instance slot-value) | |
483 | (declare (ignore instance)) | |
484 | (and (<= (length (search-text criteria)) (length slot-value)) | |
485 | (= (- (length slot-value) (length (search-text criteria))) | |
486 | (or (search (search-text criteria) slot-value | |
487 | :from-end t | |
488 | :test #'char-equal) | |
489 | -1))))) | |
490 | ||
491 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
492 | ;;;; numbers | |
493 | ||
494 | (defslot-presentation number-slot-presentation () | |
495 | ((min-value :accessor min-value :initarg :min-value :initform nil) | |
496 | (max-value :accessor max-value :initarg :max-value :initform nil))) | |
497 | ||
498 | (defcomponent number-criteria (criteria) | |
499 | ((number-input :accessor number-input :initform nil))) | |
500 | ||
501 | (defmethod applicable-criteria nconc ((s number-slot-presentation)) | |
502 | (criteria-for-slot-presentation s | |
503 | number-less-than | |
504 | number-greater-than | |
505 | number-equal-to)) | |
506 | ||
507 | (defmacro defnumber-criteria (name &key label render-on-prefix apply-criteria) | |
508 | `(progn | |
509 | (defslot-critera ,name (number-criteria) | |
510 | () | |
511 | :label ,label | |
512 | :apply-criteria (lambda (criteria instance slot-value) | |
513 | (declare (ignore instance)) | |
514 | (if (numberp slot-value) | |
515 | (if (number-input criteria) | |
516 | (funcall ,apply-criteria slot-value (number-input criteria)) | |
517 | t) | |
518 | nil))) | |
519 | ||
520 | (defmethod render-on ((res response) (obj ,name)) | |
521 | (<:as-html (format nil ,render-on-prefix (label (presentation obj)))) | |
522 | (<ucw:input :type "text" | |
523 | :reader (or (number-input obj) "") | |
524 | :writer (lambda (v) | |
525 | (unless (string= "" v) | |
526 | (let ((n (parse-float v))) | |
527 | (when n | |
528 | (setf (number-input obj) n))))))))) | |
529 | ||
530 | (defnumber-criteria number-equal-to | |
531 | :apply-criteria (lambda (slot-value number-input) | |
532 | (= slot-value number-input)) | |
533 | :label "~A is equal to:" | |
534 | :render-on-prefix "~A = ") | |
535 | ||
536 | (defnumber-criteria number-less-than | |
537 | :apply-criteria (lambda (slot-value number-input) | |
538 | (< slot-value number-input)) | |
539 | :label "~A is less than:" | |
540 | :render-on-prefix "~A < ") | |
541 | ||
542 | (defnumber-criteria number-greater-than | |
543 | :apply-criteria (lambda (slot-value number-input) | |
544 | (> slot-value number-input)) | |
545 | :label "~A is greater than:" | |
546 | :render-on-prefix "~A > ") | |
547 | ||
548 | ||
549 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
550 | ;;;; Integers | |
551 | ||
552 | (defslot-presentation integer-slot-presentation (number-slot-presentation) | |
553 | () | |
554 | (:type-name integer)) | |
555 | ||
556 | (defmethod presentation-slot-value ((slot integer-slot-presentation) instance) | |
557 | (declare (ignore instance)) | |
558 | (or (call-next-method) "")) | |
559 | ||
560 | (defmethod (setf presentation-slot-value) ((value string) (slot integer-slot-presentation) instance) | |
561 | (unless (string= "" value) | |
562 | (let ((i (parse-integer value :junk-allowed t))) | |
563 | (when i | |
564 | (setf (presentation-slot-value slot instance) (parse-integer value)))))) | |
565 | ||
566 | (defmethod present-slot ((slot integer-slot-presentation) instance) | |
567 | (if (editablep slot) | |
568 | (<ucw:input :type "text" | |
569 | :accessor (presentation-slot-value slot instance)) | |
570 | (<:as-html (presentation-slot-value slot instance)))) | |
571 | ||
572 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
573 | ;;;; Reals | |
574 | ||
575 | (defcomponent real-slot-presentation (number-slot-presentation) | |
576 | ()) | |
577 | ||
578 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
579 | ;;;; Currency (double precision reals) | |
580 | ||
581 | (defslot-presentation currency-slot-presentation (real-slot-presentation) | |
582 | () | |
583 | (:type-name currency)) | |
584 | ||
585 | (defmethod (setf presentation-slot-value) ((value string) (c currency-slot-presentation) instance) | |
586 | (let ((*read-eval* nil)) | |
587 | (unless (string= "" value) | |
588 | (let ((value (read-from-string value))) | |
589 | (when (numberp value) | |
590 | (setf (presentation-slot-value c instance) value)))))) | |
591 | ||
592 | (defmethod present-slot ((currency currency-slot-presentation) instance) | |
593 | (if (editablep currency) | |
594 | (<ucw:input :type "text" :size 10 | |
595 | :accessor (presentation-slot-value currency instance)) | |
596 | (<:as-html (presentation-slot-value currency instance)))) | |
597 | ||
598 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
599 | ;;;; dates and times | |
600 | ||
601 | (defslot-presentation timestamp-slot-presentation (slot-presentation) | |
602 | () | |
603 | (:type-name timestamp)) | |
604 | ||
605 | (defmacro deftimestamp-slot-accessor (accessor time-accessor nth-value make-time-arg) | |
606 | (let ((accessor-name (intern (strcat '#:timestamp-slot- accessor)))) | |
607 | `(progn | |
608 | (defgeneric ,accessor-name (slot instance)) | |
609 | (defgeneric (setf ,accessor-name) (value slot instance)) | |
610 | (defmethod ,accessor-name ((slot timestamp-slot-presentation) instance) | |
611 | (when (presentation-slot-value slot instance) | |
612 | (nth-value ,nth-value (,time-accessor (presentation-slot-value slot instance))))) | |
613 | (defmethod (setf ,accessor-name) ((value integer) (slot timestamp-slot-presentation) instance) | |
614 | (if (presentation-slot-value slot instance) | |
615 | (setf (presentation-slot-value slot instance) | |
616 | (make-time ,make-time-arg value :defaults (presentation-slot-value slot instance))) | |
617 | (setf (presentation-slot-value slot instance) (make-time ,make-time-arg value)))) | |
618 | (defmethod (setf ,accessor-name) ((value string) (slot timestamp-slot-presentation) instance) | |
619 | (setf (,accessor-name slot instance) | |
620 | (if (string= "" value) | |
621 | nil | |
622 | (parse-integer value)))) | |
623 | (defmethod (setf ,accessor-name) ((value null) (slot timestamp-slot-presentation) instance) | |
624 | (setf (presentation-slot-value slot instance) nil))))) | |
625 | ||
626 | (deftimestamp-slot-accessor second time-hms 2 :second) | |
627 | (deftimestamp-slot-accessor minute time-hms 1 :minute) | |
628 | (deftimestamp-slot-accessor hour time-hms 0 :hour) | |
629 | (deftimestamp-slot-accessor year time-ymd 0 :year) | |
630 | (deftimestamp-slot-accessor month time-ymd 1 :month) | |
631 | (deftimestamp-slot-accessor day time-ymd 2 :day) | |
632 | ||
633 | (defslot-presentation ymd-slot-presentation (timestamp-slot-presentation) | |
634 | () | |
635 | (:type-name date)) | |
636 | ||
637 | (defmethod present-slot ((slot ymd-slot-presentation) instance) | |
638 | (if (editablep slot) | |
639 | (<:progn | |
640 | (<ucw:input :class (css-class slot) :type "text" :size 2 | |
641 | :accessor (timestamp-slot-day slot instance)) | |
642 | "/" | |
643 | (<ucw:input :class (css-class slot) :type "text" :size 2 | |
644 | :accessor (timestamp-slot-month slot instance)) | |
645 | "/" | |
646 | (<ucw:input :class (css-class slot) :type "text" :size 4 | |
647 | :accessor (timestamp-slot-year slot instance))) | |
648 | (if (presentation-slot-value slot instance) | |
649 | (<:progn | |
650 | (<:as-html (timestamp-slot-day slot instance)) | |
651 | "/" | |
652 | (<:as-html (timestamp-slot-month slot instance)) | |
653 | "/" | |
654 | (<:as-html (timestamp-slot-year slot instance))) | |
655 | (<:as-html "---")))) | |
656 | ||
657 | (defmethod applicable-criteria nconc ((slot ymd-slot-presentation)) | |
658 | (criteria-for-slot-presentation slot | |
659 | date-before-criteria)) | |
660 | ||
661 | (defslot-critera date-before-criteria (criteria) | |
662 | ((target :accessor target)) | |
663 | :label "Date Before:") | |
664 | ||
665 | (defmethod render-on ((res response) (dbc date-before-criteria)) | |
666 | (<:as-html "Date Before: ")) | |
667 | ||
668 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
669 | ;;;; Relations | |
670 | ||
671 | (defcomponent relation-slot-presentation (slot-presentation) | |
672 | ((presentation :accessor presentation | |
673 | :initarg :presentation | |
674 | :documentation "The class of presentation | |
675 | objects used to fill the options of a select | |
676 | tag.") | |
677 | (search-presentation :accessor search-presentation | |
678 | :initarg :search-presentation | |
679 | :initform nil) | |
680 | (allow-nil-p :accessor allow-nil-p | |
681 | :initarg :allow-nil-p | |
682 | :initform t | |
683 | :documentation "Can this relation not exist."))) | |
684 | ||
685 | (defmethod presentation ((slot relation-slot-presentation)) | |
686 | (with-slots (presentation) | |
687 | slot | |
688 | (if (or (symbolp presentation) | |
689 | (consp presentation)) | |
690 | (setf presentation (apply #'make-instance (ensure-list presentation))) | |
691 | presentation))) | |
692 | ||
693 | (defgeneric get-foreign-instances (pres instance)) | |
694 | ||
695 | (defcomponent relation-criteria (criteria presentation-search) | |
696 | ((criteria :accessor criteria :initform '()))) | |
697 | ||
698 | (defmethod search-presentation ((criteria relation-criteria)) | |
699 | (or (search-presentation (presentation criteria)) | |
700 | (presentation (presentation criteria)))) | |
701 | ||
702 | ;;;; One-Of | |
703 | ||
704 | (defslot-presentation one-of-presentation (relation-slot-presentation) | |
705 | ((none-label :initarg :none-label :accessor none-label | |
706 | :initform "none")) | |
707 | (:type-name one-of)) | |
708 | ||
709 | (defmethod present-slot ((slot one-of-presentation) instance) | |
710 | (if (editablep slot) | |
711 | (<ucw:select :accessor (presentation-slot-value slot instance) | |
712 | (when (allow-nil-p slot) | |
713 | (<ucw:option :value nil (<:as-html (none-label slot)))) | |
714 | (dolist (option (get-foreign-instances (presentation slot) instance)) | |
715 | (setf (instance (presentation slot)) option) | |
716 | (<ucw:option :value option (present (presentation slot))))) | |
717 | (if (presentation-slot-value slot instance) | |
718 | (progn | |
719 | (setf (instance (presentation slot)) (presentation-slot-value slot instance)) | |
720 | (present (presentation slot))) | |
721 | (<:as-html "--")))) | |
722 | ||
723 | (defmethod applicable-criteria nconc ((slot one-of-presentation)) | |
724 | (criteria-for-slot-presentation slot | |
725 | one-of-criteria | |
726 | one-of-not-null)) | |
727 | ||
728 | (defslot-critera one-of-criteria (relation-criteria) | |
729 | ()) | |
730 | ||
731 | (defmethod label ((ooc one-of-criteria)) | |
732 | (strcat (label (presentation ooc)) " with:")) | |
733 | ||
734 | (defmethod render-on ((res response) (ooc one-of-criteria)) | |
735 | (<:as-html (label (presentation ooc)) " with:") | |
736 | (render-criteria res ooc)) | |
737 | ||
738 | (defmethod apply-criteria and ((ooc one-of-criteria) instance) | |
739 | (let ((nested-instance (presentation-slot-value (presentation ooc) instance)) | |
740 | (criteria (criteria ooc))) | |
741 | (if criteria | |
742 | (if nested-instance | |
743 | (dolist (c (criteria ooc) t) | |
744 | (unless (apply-criteria c nested-instance) | |
745 | (return-from apply-criteria nil))) | |
746 | nil) | |
747 | t))) | |
748 | ||
749 | (defslot-critera one-of-not-null (criteria) | |
750 | ()) | |
751 | ||
752 | (defmethod label ((oonn one-of-not-null)) | |
753 | (strcat (label (presentation oonn)) " exists.")) | |
754 | ||
755 | (defmethod apply-criteria and ((oonn one-of-not-null) instance) | |
756 | (not (null (presentation-slot-value (presentation oonn) instance)))) | |
757 | ||
758 | (defmethod render-on ((res response) (oonn one-of-not-null)) | |
759 | (<:as-html (label (presentation oonn)) " exists.")) | |
760 | ||
761 | ;;;; Some-Of | |
762 | ||
763 | (defslot-presentation some-of-presentation (relation-slot-presentation) | |
764 | () | |
765 | (:type-name some-of)) | |
766 | ||
767 | (defmethod present-slot ((slot some-of-presentation) instance) | |
768 | (<:ul | |
769 | (if (presentation-slot-value slot instance) | |
770 | (loop | |
771 | for option in (presentation-slot-value slot instance) | |
772 | for index upfrom 0 | |
773 | do (let ((option option) ;; loop changes the values, it does | |
774 | ;; not create fresh bindings | |
775 | (index index)) | |
776 | (<:li | |
777 | (<:table | |
778 | (<:tr | |
779 | (<:td (setf (instance (presentation slot)) option) | |
780 | (present (presentation slot))) | |
781 | (when (editablep slot) | |
782 | (<:td :align "left" :valign "top" | |
783 | (<ucw:input :type "submit" | |
784 | :action (delete-element slot instance option index) | |
785 | :value (concatenate 'string "Delete " (label slot)))))))))) | |
786 | (<:li "None.")) | |
787 | (render-add-new-item slot instance))) | |
788 | ||
789 | (defmethod render-add-new-item ((slot some-of-presentation) instance) | |
790 | (let ((new-object nil) | |
791 | (foreign-instances (get-foreign-instances (presentation slot) instance))) | |
792 | (when (and foreign-instances (editablep slot)) | |
793 | (<:li "Add: " | |
794 | (<ucw:select :accessor new-object | |
795 | (dolist (option foreign-instances) | |
796 | (setf (instance (presentation slot)) option) | |
797 | (<ucw:option :value option (present (presentation slot))))) | |
798 | (<ucw:input :type "submit" | |
799 | :action (add-element slot instance new-object) | |
800 | :value "Add"))))) | |
801 | ||
802 | (defaction add-element ((some-of some-of-presentation) instance item) | |
803 | (push item (presentation-slot-value some-of instance))) | |
804 | ||
805 | (defaction delete-element ((some-of some-of-presentation) instance item index) | |
806 | (let ((nth (nth index (presentation-slot-value some-of instance)))) | |
807 | (unless (eq nth item) | |
808 | (error "Attempting to delete the ~Dth item, which should be ~S, but the ~Dth item is actually ~S." | |
809 | index item index nth)) | |
810 | (setf (presentation-slot-value some-of instance) | |
811 | (iterate | |
812 | (for element in (presentation-slot-value some-of instance)) | |
813 | (for i upfrom 0) | |
814 | (unless (= index i) | |
815 | (collect element)))))) | |
816 | ||
817 | (defmethod applicable-criteria nconc ((slot some-of-presentation)) | |
818 | (criteria-for-slot-presentation slot | |
819 | some-of-any | |
820 | some-of-all)) | |
821 | ||
822 | (defslot-critera some-of-criteria (relation-criteria) | |
823 | ()) | |
824 | ||
825 | (defmethod render-on ((res response) (soa some-of-criteria)) | |
826 | (<:as-html (label soa)) | |
827 | (render-criteria res soa)) | |
828 | ||
829 | (defmacro defsome-of-criteria (name supers slots &key label apply-criteria) | |
830 | (with-unique-names (obj) | |
831 | `(progn | |
832 | (defslot-critera ,name ,supers ,slots) | |
833 | (defmethod label ((,obj ,name)) | |
834 | (format nil ,label (label (presentation ,obj)))) | |
835 | (defmethod apply-criteria and ((,obj ,name) instance) | |
836 | (let ((nested-instances (presentation-slot-value (presentation ,obj) instance)) | |
837 | (criteria (criteria ,obj))) | |
838 | (if criteria | |
839 | (if nested-instances | |
840 | (funcall ,apply-criteria (criteria ,obj) nested-instances) | |
841 | nil) | |
842 | t)))))) | |
843 | ||
844 | (defsome-of-criteria some-of-any (some-of-criteria) | |
845 | () | |
846 | :label "Any ~A with:" | |
847 | :apply-criteria (lambda (criteria nested-instances) | |
848 | ;; return T if any nested-instance meets all of criteria | |
849 | (some (lambda (instance) | |
850 | (every (lambda (criteria) | |
851 | (apply-criteria criteria instance)) | |
852 | criteria)) | |
853 | nested-instances))) | |
854 | ||
855 | (defsome-of-criteria some-of-all (some-of-criteria) | |
856 | () | |
857 | :label "All ~A with:" | |
858 | :apply-criteria (lambda (criteria nested-instances) | |
859 | ;; return T only if every nested-instances meets | |
860 | ;; all of our criteria | |
861 | (every (lambda (instance) | |
862 | (every (lambda (criteria) | |
863 | (apply-criteria criteria instance)) | |
864 | criteria)) | |
865 | nested-instances))) | |
866 | ||
867 | ;;;; An-Object | |
868 | ||
869 | (defslot-presentation an-object-presentation (one-of-presentation) | |
870 | () | |
871 | (:type-name an-object)) | |
872 | ||
873 | (defmethod present-slot ((slot an-object-presentation) instance) | |
874 | (if (presentation-slot-value slot instance) | |
875 | (progn | |
876 | (setf (instance (presentation slot)) (presentation-slot-value slot instance)) | |
877 | (present (presentation slot)) | |
878 | (<ucw:input :type "submit" :action (delete-an-object slot instance) | |
879 | :value (concatenate 'string "Delete " (label slot)))) | |
880 | (<ucw:input :type "submit" :action (create-an-object slot instance) :value "Create"))) | |
881 | ||
882 | (defaction delete-an-object ((slot an-object-presentation) instance) | |
883 | (setf (presentation-slot-value slot instance) nil)) | |
884 | ||
885 | (defaction create-an-object ((slot an-object-presentation) instance) | |
886 | (let ((obj (make-new-instance (presentation slot) instance))) | |
887 | (format t "Setting (presentation-slot-value ~S ~S) to ~S.~%" slot instance obj) | |
888 | (setf (presentation-slot-value slot instance) obj))) | |
889 | ||
890 | ;;;; Some-Objects | |
891 | ||
892 | (defslot-presentation some-objects-presentation (some-of-presentation) | |
893 | () | |
894 | (:type-name some-objects)) | |
895 | ||
896 | (defmethod render-add-new-item ((slot some-objects-presentation) instance) | |
897 | (when (editablep slot) | |
898 | (<:li (<ucw:input :type "submit" | |
899 | :action (add-an-object slot instance) | |
900 | :value "Add new object.")))) | |
901 | ||
902 | (defgeneric make-new-instance (presentation instance) | |
903 | (:documentation "Create an new instance suitable for | |
904 | PRESENTATION which will be added to INSTANCE (according to | |
905 | PRESENTATION).")) | |
906 | ||
907 | (defaction add-an-object ((slot some-objects-presentation) instance) | |
908 | (push (make-new-instance (presentation slot) instance) (presentation-slot-value slot instance))) | |
909 | ||
910 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
911 | ;;;; Convience macros/functions | |
912 | ||
913 | (defmacro slot-presentations (&rest slot-specs) | |
914 | `(list ,@(mapcar (lambda (slot) | |
915 | (let ((class-name (gethash (car slot) *presentation-slot-type-mapping*))) | |
916 | (if class-name | |
917 | `(make-instance ',class-name ,@(cdr slot)) | |
918 | (error "Unknown slot type ~S." (car slot))))) | |
919 | slot-specs))) | |
920 | ||
921 | (defmacro defpresentation (name supers slots &rest default-initargs) | |
922 | `(defcomponent ,name ,supers | |
923 | () | |
924 | (:default-initargs | |
925 | ,@(when slots `(:slots (slot-presentations ,@slots))) | |
926 | ,@default-initargs))) | |
927 |