added a nil check in new slot presentations
[clinton/lisp-on-lines.git] / src / static-presentations.lisp
CommitLineData
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
9A presentation object is a UCW component which knows how to
10read/write different kinds of data types.
11
12There are three major kinds of presentations:
13
141) object-presentation - Managing a single object.
15
162) slot-presentation - Managing the single parts (slots) which
17 make up an object.
18
193) collection-presentation - Managing multiple objects.
20
21Presentations are independant of the underlying application
22specific lisp objects they manage. A presentation can be created
23once and reused or modified before and aftre it has been used.
24
25Presentations fulfill two distinct roles: on the one hand they
26create, given a lisp object, a grahpical (html) rendering of that
27object, they also deal with whatever operations the user might
28wish to perform on that object.
29
30* Creating Presentation Objects
31
32Presentation objects are created by making an instance of either
33an object-presentation or a collection-presentation and then
34filling 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
143This 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