stray paren in last patch
[clinton/lisp-on-lines.git] / src / static-presentations.lisp
1 ;;;; -*- lisp -*-
2
3 (in-package :lisp-on-lines)
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)
425 (<ucw:input :type "checkbox" :accessor (presentation-slot-value slot instance)))
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) i)))))
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 ((as-money-p :accessor as-money-p :initarg :as-money-p :initform nil))
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 (format nil (if (as-money-p currency)
597 "$~$"
598 "~D")
599 (presentation-slot-value currency instance)) )))
600
601 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
602 ;;;; dates and times
603
604 (defslot-presentation timestamp-slot-presentation (slot-presentation)
605 ()
606 (:type-name timestamp))
607
608 (defmacro deftimestamp-slot-accessor (accessor time-accessor nth-value make-time-arg)
609 (let ((accessor-name (intern (strcat '#:timestamp-slot- accessor))))
610 `(progn
611 (defgeneric ,accessor-name (slot instance))
612 (defgeneric (setf ,accessor-name) (value slot instance))
613 (defmethod ,accessor-name ((slot timestamp-slot-presentation) instance)
614 (when (presentation-slot-value slot instance)
615 (nth-value ,nth-value (,time-accessor (presentation-slot-value slot instance)))))
616 (defmethod (setf ,accessor-name) ((value integer) (slot timestamp-slot-presentation) instance)
617 (if (presentation-slot-value slot instance)
618 (setf (presentation-slot-value slot instance)
619 (make-time ,make-time-arg value :defaults (presentation-slot-value slot instance)))
620 (setf (presentation-slot-value slot instance) (make-time ,make-time-arg value))))
621 (defmethod (setf ,accessor-name) ((value string) (slot timestamp-slot-presentation) instance)
622 (setf (,accessor-name slot instance)
623 (if (string= "" value)
624 nil
625 (parse-integer value))))
626 (defmethod (setf ,accessor-name) ((value null) (slot timestamp-slot-presentation) instance)
627 (setf (presentation-slot-value slot instance) nil)))))
628
629 (deftimestamp-slot-accessor second time-hms 2 :second)
630 (deftimestamp-slot-accessor minute time-hms 1 :minute)
631 (deftimestamp-slot-accessor hour time-hms 0 :hour)
632 (deftimestamp-slot-accessor year time-ymd 0 :year)
633 (deftimestamp-slot-accessor month time-ymd 1 :month)
634 (deftimestamp-slot-accessor day time-ymd 2 :day)
635
636 (defslot-presentation ymd-slot-presentation (timestamp-slot-presentation)
637 ()
638 (:type-name date))
639
640 (defmethod present-slot ((slot ymd-slot-presentation) instance)
641 (if (editablep slot)
642 (<:progn
643 (<ucw:input :class (css-class slot) :type "text" :size 2
644 :accessor (timestamp-slot-day slot instance))
645 "/"
646 (<ucw:input :class (css-class slot) :type "text" :size 2
647 :accessor (timestamp-slot-month slot instance))
648 "/"
649 (<ucw:input :class (css-class slot) :type "text" :size 4
650 :accessor (timestamp-slot-year slot instance)))
651 (if (presentation-slot-value slot instance)
652 (<:progn
653 (<:as-html (timestamp-slot-day slot instance))
654 "/"
655 (<:as-html (timestamp-slot-month slot instance))
656 "/"
657 (<:as-html (timestamp-slot-year slot instance)))
658 (<:as-html "---"))))
659
660 (defmethod applicable-criteria nconc ((slot ymd-slot-presentation))
661 (criteria-for-slot-presentation slot
662 date-before-criteria))
663
664 (defslot-critera date-before-criteria (criteria)
665 ((target :accessor target))
666 :label "Date Before:")
667
668 (defmethod render-on ((res response) (dbc date-before-criteria))
669 (<:as-html "Date Before: "))
670
671 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
672 ;;;; Relations
673
674 (defcomponent relation-slot-presentation (slot-presentation)
675 ((presentation :accessor presentation
676 :initarg :presentation
677 :documentation "The class of presentation
678 objects used to fill the options of a select
679 tag.")
680 (search-presentation :accessor search-presentation
681 :initarg :search-presentation
682 :initform nil)
683 (allow-nil-p :accessor allow-nil-p
684 :initarg :allow-nil-p
685 :initform t
686 :documentation "Can this relation not exist.")))
687
688 (defmethod presentation ((slot relation-slot-presentation))
689 (with-slots (presentation)
690 slot
691 (if (or (symbolp presentation)
692 (consp presentation))
693 (setf presentation (apply #'make-instance (ensure-list presentation)))
694 presentation)))
695
696 (defgeneric get-foreign-instances (pres instance))
697
698 (defcomponent relation-criteria (criteria presentation-search)
699 ((criteria :accessor criteria :initform '())))
700
701 (defmethod search-presentation ((criteria relation-criteria))
702 (or (search-presentation (presentation criteria))
703 (presentation (presentation criteria))))
704
705 ;;;; One-Of
706
707 (defslot-presentation one-of-presentation (relation-slot-presentation)
708 ((none-label :initarg :none-label :accessor none-label
709 :initform "none"))
710 (:type-name one-of))
711
712 (defmethod present-slot ((slot one-of-presentation) instance)
713 (if (editablep slot)
714 (<ucw:select :accessor (presentation-slot-value slot instance)
715 (when (allow-nil-p slot)
716 (<ucw:option :value nil (<:as-html (none-label slot))))
717 (dolist (option (get-foreign-instances (presentation slot) instance))
718 (setf (instance (presentation slot)) option)
719 (<ucw:option :value option (present (presentation slot)))))
720 (if (presentation-slot-value slot instance)
721 (progn
722 (setf (instance (presentation slot)) (presentation-slot-value slot instance))
723 (present (presentation slot)))
724 (<:as-html "--"))))
725
726 (defmethod applicable-criteria nconc ((slot one-of-presentation))
727 (criteria-for-slot-presentation slot
728 one-of-criteria
729 one-of-not-null))
730
731 (defslot-critera one-of-criteria (relation-criteria)
732 ())
733
734 (defmethod label ((ooc one-of-criteria))
735 (strcat (label (presentation ooc)) " with:"))
736
737 (defmethod render-on ((res response) (ooc one-of-criteria))
738 (<:as-html (label (presentation ooc)) " with:")
739 (render-criteria res ooc))
740
741 (defmethod apply-criteria and ((ooc one-of-criteria) instance)
742 (let ((nested-instance (presentation-slot-value (presentation ooc) instance))
743 (criteria (criteria ooc)))
744 (if criteria
745 (if nested-instance
746 (dolist (c (criteria ooc) t)
747 (unless (apply-criteria c nested-instance)
748 (return-from apply-criteria nil)))
749 nil)
750 t)))
751
752 (defslot-critera one-of-not-null (criteria)
753 ())
754
755 (defmethod label ((oonn one-of-not-null))
756 (strcat (label (presentation oonn)) " exists."))
757
758 (defmethod apply-criteria and ((oonn one-of-not-null) instance)
759 (not (null (presentation-slot-value (presentation oonn) instance))))
760
761 (defmethod render-on ((res response) (oonn one-of-not-null))
762 (<:as-html (label (presentation oonn)) " exists."))
763
764 ;;;; Some-Of
765
766 (defslot-presentation some-of-presentation (relation-slot-presentation)
767 ()
768 (:type-name some-of))
769
770 (defmethod present-slot ((slot some-of-presentation) instance)
771 (<:ul
772 (if (presentation-slot-value slot instance)
773 (loop
774 for option in (presentation-slot-value slot instance)
775 for index upfrom 0
776 do (let ((option option) ;; loop changes the values, it does
777 ;; not create fresh bindings
778 (index index))
779 (<:li
780 (<:table
781 (<:tr
782 (<:td (setf (instance (presentation slot)) option)
783 (present (presentation slot)))
784 (when (editablep slot)
785 (<:td :align "left" :valign "top"
786 (<ucw:input :type "submit"
787 :action (delete-element slot instance option index)
788 :value (concatenate 'string "Delete " (label slot))))))))))
789 (<:li "None."))
790 (render-add-new-item slot instance)))
791
792 (defmethod render-add-new-item ((slot some-of-presentation) instance)
793 (let ((new-object nil)
794 (foreign-instances (get-foreign-instances (presentation slot) instance)))
795 (when (and foreign-instances (editablep slot))
796 (<:li "Add: "
797 (<ucw:select :accessor new-object
798 (dolist (option foreign-instances)
799 (setf (instance (presentation slot)) option)
800 (<ucw:option :value option (present (presentation slot)))))
801 (<ucw:input :type "submit"
802 :action (add-element slot instance new-object)
803 :value "Add")))))
804
805 (defaction add-element ((some-of some-of-presentation) instance item)
806 (push item (presentation-slot-value some-of instance)))
807
808 (defaction delete-element ((some-of some-of-presentation) instance item index)
809 (let ((nth (nth index (presentation-slot-value some-of instance))))
810 (unless (eq nth item)
811 (error "Attempting to delete the ~Dth item, which should be ~S, but the ~Dth item is actually ~S."
812 index item index nth))
813 (setf (presentation-slot-value some-of instance)
814 (iterate
815 (for element in (presentation-slot-value some-of instance))
816 (for i upfrom 0)
817 (unless (= index i)
818 (collect element))))))
819
820 (defmethod applicable-criteria nconc ((slot some-of-presentation))
821 (criteria-for-slot-presentation slot
822 some-of-any
823 some-of-all))
824
825 (defslot-critera some-of-criteria (relation-criteria)
826 ())
827
828 (defmethod render-on ((res response) (soa some-of-criteria))
829 (<:as-html (label soa))
830 (render-criteria res soa))
831
832 (defmacro defsome-of-criteria (name supers slots &key label apply-criteria)
833 (with-unique-names (obj)
834 `(progn
835 (defslot-critera ,name ,supers ,slots)
836 (defmethod label ((,obj ,name))
837 (format nil ,label (label (presentation ,obj))))
838 (defmethod apply-criteria and ((,obj ,name) instance)
839 (let ((nested-instances (presentation-slot-value (presentation ,obj) instance))
840 (criteria (criteria ,obj)))
841 (if criteria
842 (if nested-instances
843 (funcall ,apply-criteria (criteria ,obj) nested-instances)
844 nil)
845 t))))))
846
847 (defsome-of-criteria some-of-any (some-of-criteria)
848 ()
849 :label "Any ~A with:"
850 :apply-criteria (lambda (criteria nested-instances)
851 ;; return T if any nested-instance meets all of criteria
852 (some (lambda (instance)
853 (every (lambda (criteria)
854 (apply-criteria criteria instance))
855 criteria))
856 nested-instances)))
857
858 (defsome-of-criteria some-of-all (some-of-criteria)
859 ()
860 :label "All ~A with:"
861 :apply-criteria (lambda (criteria nested-instances)
862 ;; return T only if every nested-instances meets
863 ;; all of our criteria
864 (every (lambda (instance)
865 (every (lambda (criteria)
866 (apply-criteria criteria instance))
867 criteria))
868 nested-instances)))
869
870 ;;;; An-Object
871
872 (defslot-presentation an-object-presentation (one-of-presentation)
873 ()
874 (:type-name an-object))
875
876 (defmethod present-slot ((slot an-object-presentation) instance)
877 (if (presentation-slot-value slot instance)
878 (progn
879 (setf (instance (presentation slot)) (presentation-slot-value slot instance))
880 (present (presentation slot))
881 (<ucw:input :type "submit" :action (delete-an-object slot instance)
882 :value (concatenate 'string "Delete " (label slot))))
883 (<ucw:input :type "submit" :action (create-an-object slot instance) :value "Create")))
884
885 (defaction delete-an-object ((slot an-object-presentation) instance)
886 (setf (presentation-slot-value slot instance) nil))
887
888 (defaction create-an-object ((slot an-object-presentation) instance)
889 (let ((obj (make-new-instance (presentation slot) instance)))
890 (format t "Setting (presentation-slot-value ~S ~S) to ~S.~%" slot instance obj)
891 (setf (presentation-slot-value slot instance) obj)))
892
893 ;;;; Some-Objects
894
895 (defslot-presentation some-objects-presentation (some-of-presentation)
896 ()
897 (:type-name some-objects))
898
899 (defmethod render-add-new-item ((slot some-objects-presentation) instance)
900 (when (editablep slot)
901 (<:li (<ucw:input :type "submit"
902 :action (add-an-object slot instance)
903 :value "Add new object."))))
904
905 (defgeneric make-new-instance (presentation instance)
906 (:documentation "Create an new instance suitable for
907 PRESENTATION which will be added to INSTANCE (according to
908 PRESENTATION)."))
909
910 (defaction add-an-object ((slot some-objects-presentation) instance)
911 (push (make-new-instance (presentation slot) instance) (presentation-slot-value slot instance)))
912
913 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
914 ;;;; Convience macros/functions
915
916 (defmacro slot-presentations (&rest slot-specs)
917 `(list ,@(mapcar (lambda (slot)
918 (let ((class-name (gethash (car slot) *presentation-slot-type-mapping*)))
919 (if class-name
920 `(make-instance ',class-name ,@(cdr slot))
921 (error "Unknown slot type ~S." (car slot)))))
922 slot-specs)))
923
924 (defmacro defpresentation (name supers slots &rest default-initargs)
925 `(defcomponent ,name ,supers
926 ()
927 (:default-initargs
928 ,@(when slots `(:slots (slot-presentations ,@slots)))
929 ,@default-initargs)))
930