3 (in-package :lisp-on-lines
)
5 (defcomponent presentation
()
6 ((css-class :accessor css-class
:initarg
:css-class
:initform nil
))
7 (:documentation
"The super class of all UCW presentations.
9 A presentation object is a UCW component which knows how to
10 read/write different kinds of data types.
12 There are three major kinds of presentations:
14 1) object-presentation - Managing a single object.
16 2) slot-presentation - Managing the single parts (slots) which
19 3) collection-presentation - Managing multiple objects.
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.
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.
30 * Creating Presentation Objects
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."))
36 (defgeneric present
(presentation)
37 (:documentation
"Render PRESENTATION (generally called from render-on)."))
39 (defmacro present-object
(object &key using presentation
)
40 (assert (xor using presentation
)
42 "Must specify exactly one of :USING and :PRESENTATION.")
44 (destructuring-bind (type &rest args
)
46 `(call ',type
,@args
'instance
,object
))
47 (rebinding (presentation)
49 (setf (slot-value ,presentation
'instance
) ,object
)
50 (call-component self
,presentation
)))))
52 (defmacro present-collection
(presentation-type &rest initargs
)
53 `(call ',presentation-type
,@initargs
))
55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
56 ;;;; object-presentation
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."))
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."
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
))))
77 (defmethod render-options ((pres object-presentation
) instance
)
78 (declare (ignore instance pres
))
80 (<:td
:colspan
2 :align
"center"
81 (<ucw
:input
:type
"submit" :action
(ok pres
) :value
"Ok."))) |
# )
83 (defaction ok
((o object-presentation
) &optional
(value (slot-value o
'instance
)))
86 (defmethod find-slot ((o object-presentation
) slot-label
)
87 (find slot-label
(slots o
) :test
#'string
= :key
#'label
))
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.
95 (defcomponent inline-object-presentation
(object-presentation)
98 (defmethod render-options ((pres inline-object-presentation
) instance
)
99 (declare (ignore instance
))
102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
103 ;;;; 'one line' objects
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.")))
113 (defmethod present ((pres one-line-presentation
))
114 (<:as-is
(before 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
)))
122 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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
)))
133 (defmethod initialize-instance :after
((l list-presentation
) &rest initargs
)
134 (declare (ignore initargs
))
135 (setf (instances l
) (get-all-instances l
)))
137 (defmethod render-on ((res response
) (l list-presentation
))
140 (defgeneric get-all-instances
(listing)
141 (:documentation
"Returns all the instances which should be viewable with LISTING.
143 This method is also used by relation-slot-presentations for the same reason."))
145 (defmethod present ((listing list-presentation
))
146 (<:table
:class
(css-class listing
)
147 (render-list-heading listing
)
149 (for element in
(instances listing
))
151 (render-list-row listing element index
))))
153 (defmethod render-list-heading ((listing list-presentation
))
154 (<:tr
:class
"presentation-list-heading-row"
156 (dolist (slot (slots listing
))
157 (<:th
:class
"presentation-list-heading-cell"
158 (<:as-html
(label slot
))))
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
))))
174 (when (deleteablep listing
)
176 (<ucw
:input
:type
"submit"
177 :action
(delete-from-listing listing object index
)
178 :value
(delete-label listing
)))))))
180 (defgeneric/cc create-from-listing
(listing))
182 (defmethod/cc create-from-listing
:after
((l list-presentation
))
183 (setf (instances l
) (get-all-instances l
)))
185 (defgeneric/cc delete-from-listing
(listing item index
))
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
)))
191 (defgeneric/cc edit-from-listing
(listing item index
))
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
)))
197 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
198 ;;;; Searching/Filtering
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.")))
209 (defgeneric applicable-criteria
(presentation)
210 (:method-combination nconc
))
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
)
219 (defcomponent criteria
()
220 ((presentation :accessor presentation
:initarg
:presentation
)))
222 (defaction add-criteria
((search presentation-search
) (criteria criteria
))
223 (push criteria
(criteria search
)))
225 (defaction drop-criteria
((search presentation-search
) (criteria criteria
))
226 (setf (criteria search
) (delete criteria
(criteria search
))))
228 (defgeneric apply-criteria
(criteria instance
)
229 (:method-combination and
))
231 (defmethod valid-instances ((search presentation-search
))
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
)))
241 (defcomponent search-results-list
(list-presentation)
242 ((search-presentation :accessor search-presentation
)))
244 (defmethod render-on ((res response
) (s presentation-search
))
246 (let ((listing (list-presentation s
)))
248 (<:tr
:class
"presentation-list-heading-row"
250 (dolist (slot (slots (list-presentation s
)))
251 (<:th
:class
"presentation-list-heading-cell"
252 (<:as-html
(label slot
))))
255 for object in
(valid-instances s
)
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
))))
268 (when (deleteablep listing
)
270 (<ucw
:input
:type
"submit"
271 :action
(delete-from-search s object index
)
272 :value
(delete-label listing
)))))))))
273 (<:p
"Search Criteria:")
275 (render-criteria res s
)
276 (<:li
(<ucw
:input
:type
"submit" :action
(refresh-component s
)
279 (defmethod render-criteria ((res response
) (s presentation-search
))
281 (dolist (c (criteria s
))
282 (<:li
(render-on res 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
)
293 (defgeneric/cc edit-from-search
(search object index
))
295 (defgeneric/cc delete-from-search
(search object index
))
299 (defcomponent negated-criteria
(criteria)
300 ((criteria :accessor criteria
:initform nil
)))
302 (defmethod label ((n negated-criteria
)) "Not:")
304 (defmethod render-on ((res response
) (n negated-criteria
))
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
)
316 (defmethod apply-criteria and
((n negated-criteria
) instance
)
318 (not (apply-criteria (criteria n
) instance
))
321 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
322 ;;;; Slot presentations
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)))
338 (defmethod print-object ((s slot-presentation
) stream
)
341 (print-unreadable-object (s stream
:type t
:identity t
)
342 (princ (label s
) stream
)
344 (princ (slot-value s
'print-object-label
) stream
)
345 (princ ")" stream
))))
347 (defgeneric present-slot
(slot instance
))
349 (defmethod initialize-instance :after
((presentation slot-presentation
)
350 &key slot-name getter setter
&allow-other-keys
)
352 (setf (slot-value presentation
'print-object-label
) slot-name
)
353 (setf (slot-value presentation
'print-object-label
) getter
))
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
)))))
364 (defvar *presentation-slot-type-mapping
* (make-hash-table :test
'eql
))
366 (defun register-slot-type-mapping (name class-name
)
367 (setf (gethash name
*presentation-slot-type-mapping
*) class-name
))
369 (defmacro defslot-presentation
(name supers slots
&rest options
)
371 (defcomponent ,name
,(or supers
`(slot-presentation))
373 ,@(remove :type-name options
:key
#'car
))
374 ,(let ((type-name (assoc :type-name options
)))
376 `(register-slot-type-mapping ',(second type-name
) ',name
)))
379 (defgeneric presentation-slot-value
(slot instance
)
380 (:method
((slot slot-presentation
) instance
)
381 (funcall (getter slot
) instance
)))
383 (defgeneric (setf presentation-slot-value
) (value slot instance
)
384 (:method
(value (slot slot-presentation
) instance
)
385 (funcall (setter slot
) value instance
)))
387 (defmethod applicable-criteria nconc
((s slot-presentation
))
390 (defmacro criteria-for-slot-presentation
(slot &body criteria-clauses
)
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
)))
400 (defmacro defslot-critera
(class-name supers slots
&key label apply-criteria
)
401 (with-unique-names (obj instance
)
404 `(defcomponent ,class-name
,supers
,slots
)
406 `(defmethod label ((,obj
,class-name
))
407 (format nil
,label
(label (presentation ,obj
)))))
410 `(defmethod apply-criteria and
((,obj
,class-name
) ,instance
)
411 (funcall ,apply-criteria
414 (presentation-slot-value (presentation ,obj
) ,instance
))))
415 `(quote ,class-name
))))
417 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
420 (defslot-presentation boolean-slot-presentation
()
422 (:type-name boolean
))
424 (defmethod present-slot ((slot boolean-slot-presentation
) instance
)
425 (<ucw
:input
:type
"checkbox" :accessor
(presentation-slot-value slot instance
)))
427 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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
))
435 (defmethod present-slot ((slot string-slot-presentation
) instance
)
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
))
442 (+ 3 (length (presentation-slot-value slot instance
)))))
443 :maxlength
(max-length slot
))
444 (<:as-html
(presentation-slot-value slot instance
))))
448 (defmethod applicable-criteria nconc
((s string-slot-presentation
))
449 (criteria-for-slot-presentation s
454 (defcomponent string-criteria
(criteria)
455 ((search-text :accessor search-text
:initform nil
)))
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))
461 (defslot-critera string-contains
(string-criteria)
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
))))
469 (defslot-critera string-starts-with
(string-contains)
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
479 (defslot-critera string-ends-with
(string-contains)
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
491 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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
)))
498 (defcomponent number-criteria
(criteria)
499 ((number-input :accessor number-input
:initform nil
)))
501 (defmethod applicable-criteria nconc
((s number-slot-presentation
))
502 (criteria-for-slot-presentation s
507 (defmacro defnumber-criteria
(name &key label render-on-prefix apply-criteria
)
509 (defslot-critera ,name
(number-criteria)
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
))
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
) "")
525 (unless (string= "" v
)
526 (let ((n (parse-float v
)))
528 (setf (number-input obj
) n
)))))))))
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 = ")
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 < ")
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 > ")
549 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
552 (defslot-presentation integer-slot-presentation
(number-slot-presentation)
554 (:type-name integer
))
556 (defmethod presentation-slot-value ((slot integer-slot-presentation
) instance
)
557 (declare (ignore instance
))
558 (or (call-next-method) ""))
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
)))
564 (setf (presentation-slot-value slot instance
) i
)))))
566 (defmethod present-slot ((slot integer-slot-presentation
) instance
)
568 (<ucw
:input
:type
"text"
569 :accessor
(presentation-slot-value slot instance
))
570 (<:as-html
(presentation-slot-value slot instance
))))
572 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
575 (defcomponent real-slot-presentation
(number-slot-presentation)
578 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
579 ;;;; Currency (double precision reals)
581 (defslot-presentation currency-slot-presentation
(real-slot-presentation)
583 (:type-name currency
))
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
))))))
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
))))
598 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
601 (defslot-presentation timestamp-slot-presentation
(slot-presentation)
603 (:type-name timestamp
))
605 (defmacro deftimestamp-slot-accessor
(accessor time-accessor nth-value make-time-arg
)
606 (let ((accessor-name (intern (strcat '#:timestamp-slot- accessor
))))
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
)
622 (parse-integer value
))))
623 (defmethod (setf ,accessor-name
) ((value null
) (slot timestamp-slot-presentation
) instance
)
624 (setf (presentation-slot-value slot instance
) nil
)))))
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
)
633 (defslot-presentation ymd-slot-presentation
(timestamp-slot-presentation)
637 (defmethod present-slot ((slot ymd-slot-presentation
) instance
)
640 (<ucw
:input
:class
(css-class slot
) :type
"text" :size
2
641 :accessor
(timestamp-slot-day slot instance
))
643 (<ucw
:input
:class
(css-class slot
) :type
"text" :size
2
644 :accessor
(timestamp-slot-month slot instance
))
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
)
650 (<:as-html
(timestamp-slot-day slot instance
))
652 (<:as-html
(timestamp-slot-month slot instance
))
654 (<:as-html
(timestamp-slot-year slot instance
)))
657 (defmethod applicable-criteria nconc
((slot ymd-slot-presentation
))
658 (criteria-for-slot-presentation slot
659 date-before-criteria
))
661 (defslot-critera date-before-criteria
(criteria)
662 ((target :accessor target
))
663 :label
"Date Before:")
665 (defmethod render-on ((res response
) (dbc date-before-criteria
))
666 (<:as-html
"Date Before: "))
668 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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
677 (search-presentation :accessor search-presentation
678 :initarg
:search-presentation
680 (allow-nil-p :accessor allow-nil-p
681 :initarg
:allow-nil-p
683 :documentation
"Can this relation not exist.")))
685 (defmethod presentation ((slot relation-slot-presentation
))
686 (with-slots (presentation)
688 (if (or (symbolp presentation
)
689 (consp presentation
))
690 (setf presentation
(apply #'make-instance
(ensure-list presentation
)))
693 (defgeneric get-foreign-instances
(pres instance
))
695 (defcomponent relation-criteria
(criteria presentation-search
)
696 ((criteria :accessor criteria
:initform
'())))
698 (defmethod search-presentation ((criteria relation-criteria
))
699 (or (search-presentation (presentation criteria
))
700 (presentation (presentation criteria
))))
704 (defslot-presentation one-of-presentation
(relation-slot-presentation)
705 ((none-label :initarg
:none-label
:accessor none-label
709 (defmethod present-slot ((slot one-of-presentation
) instance
)
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
)
719 (setf (instance (presentation slot
)) (presentation-slot-value slot instance
))
720 (present (presentation slot
)))
723 (defmethod applicable-criteria nconc
((slot one-of-presentation
))
724 (criteria-for-slot-presentation slot
728 (defslot-critera one-of-criteria
(relation-criteria)
731 (defmethod label ((ooc one-of-criteria
))
732 (strcat (label (presentation ooc
)) " with:"))
734 (defmethod render-on ((res response
) (ooc one-of-criteria
))
735 (<:as-html
(label (presentation ooc
)) " with:")
736 (render-criteria res ooc
))
738 (defmethod apply-criteria and
((ooc one-of-criteria
) instance
)
739 (let ((nested-instance (presentation-slot-value (presentation ooc
) instance
))
740 (criteria (criteria ooc
)))
743 (dolist (c (criteria ooc
) t
)
744 (unless (apply-criteria c nested-instance
)
745 (return-from apply-criteria nil
)))
749 (defslot-critera one-of-not-null
(criteria)
752 (defmethod label ((oonn one-of-not-null
))
753 (strcat (label (presentation oonn
)) " exists."))
755 (defmethod apply-criteria and
((oonn one-of-not-null
) instance
)
756 (not (null (presentation-slot-value (presentation oonn
) instance
))))
758 (defmethod render-on ((res response
) (oonn one-of-not-null
))
759 (<:as-html
(label (presentation oonn
)) " exists."))
763 (defslot-presentation some-of-presentation
(relation-slot-presentation)
765 (:type-name some-of
))
767 (defmethod present-slot ((slot some-of-presentation
) instance
)
769 (if (presentation-slot-value slot instance
)
771 for option in
(presentation-slot-value slot instance
)
773 do
(let ((option option
) ;; loop changes the values, it does
774 ;; not create fresh bindings
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
))))))))))
787 (render-add-new-item slot instance
)))
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
))
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
)
802 (defaction add-element
((some-of some-of-presentation
) instance item
)
803 (push item
(presentation-slot-value some-of instance
)))
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
)
812 (for element in
(presentation-slot-value some-of instance
))
815 (collect element
))))))
817 (defmethod applicable-criteria nconc
((slot some-of-presentation
))
818 (criteria-for-slot-presentation slot
822 (defslot-critera some-of-criteria
(relation-criteria)
825 (defmethod render-on ((res response
) (soa some-of-criteria
))
826 (<:as-html
(label soa
))
827 (render-criteria res soa
))
829 (defmacro defsome-of-criteria
(name supers slots
&key label apply-criteria
)
830 (with-unique-names (obj)
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
)))
840 (funcall ,apply-criteria
(criteria ,obj
) nested-instances
)
844 (defsome-of-criteria some-of-any
(some-of-criteria)
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
))
855 (defsome-of-criteria some-of-all
(some-of-criteria)
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
))
869 (defslot-presentation an-object-presentation
(one-of-presentation)
871 (:type-name an-object
))
873 (defmethod present-slot ((slot an-object-presentation
) instance
)
874 (if (presentation-slot-value slot instance
)
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")))
882 (defaction delete-an-object
((slot an-object-presentation
) instance
)
883 (setf (presentation-slot-value slot instance
) nil
))
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
)))
892 (defslot-presentation some-objects-presentation
(some-of-presentation)
894 (:type-name some-objects
))
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."))))
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
907 (defaction add-an-object
((slot some-objects-presentation
) instance
)
908 (push (make-new-instance (presentation slot
) instance
) (presentation-slot-value slot instance
)))
910 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
911 ;;;; Convience macros/functions
913 (defmacro slot-presentations
(&rest slot-specs
)
914 `(list ,@(mapcar (lambda (slot)
915 (let ((class-name (gethash (car slot
) *presentation-slot-type-mapping
*)))
917 `(make-instance ',class-name
,@(cdr slot
))
918 (error "Unknown slot type ~S." (car slot
)))))
921 (defmacro defpresentation
(name supers slots
&rest default-initargs
)
922 `(defcomponent ,name
,supers
925 ,@(when slots
`(:slots
(slot-presentations ,@slots
)))
926 ,@default-initargs
)))