[clinton/lisp-on-lines.git] / src / static-presentations.lisp

;;;; -*- lisp -*-

(in-package :lisp-on-lines)

(defcomponent presentation ()
  ((css-class :accessor css-class :initarg :css-class :initform nil))
  (:documentation "The super class of all UCW presentations.

A presentation object is a UCW component which knows how to
read/write different kinds of data types.

There are three major kinds of presentations:

1) object-presentation - Managing a single object.

2) slot-presentation - Managing the single parts (slots) which
   make up an object.

3) collection-presentation - Managing multiple objects.

Presentations are independant of the underlying application
specific lisp objects they manage. A presentation can be created
once and reused or modified before and aftre it has been used.

Presentations fulfill two distinct roles: on the one hand they
create, given a lisp object, a grahpical (html) rendering of that
object, they also deal with whatever operations the user might
wish to perform on that object.

* Creating Presentation Objects

Presentation objects are created by making an instance of either
an object-presentation or a collection-presentation and then
filling the slots property of this object."))

(defgeneric present (presentation)
  (:documentation "Render PRESENTATION (generally called from render-on)."))

(defmacro present-object (object &key using presentation)
  (assert (xor using presentation)
	  (using presentation)
	  "Must specify exactly one of :USING and :PRESENTATION.")
  (if using
      (destructuring-bind (type &rest args)
	  (ensure-list using)
	`(call ',type ,@args 'instance ,object))
      (rebinding (presentation)
	`(progn
	   (setf (slot-value ,presentation 'instance) ,object)
	   (call-component self ,presentation)))))

(defmacro present-collection (presentation-type &rest initargs)
  `(call ',presentation-type ,@initargs))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; object-presentation

(defcomponent object-presentation (presentation)
  ((slots :accessor slots :initarg :slots :initform nil)
   (instance :initform nil :initarg instance :accessor instance))
  (:documentation "Presentations for single objects."))

(defmethod render-on ((res response) (o object-presentation))
  (unless (slot-value o 'instance)
    (error "Attempting to render the presentation ~S, but it has no instance object to present."
	   o))
  (present o))

(defmethod present ((pres object-presentation))
  (<:table :class (css-class pres)
    (dolist (slot (slots pres))
      (<:tr :class "presentation-slot-row"
        (<:td :class "presentation-slot-label" (<:as-html (label slot)))
	(<:td :class "presentation-slot-value" (present-slot slot (instance pres)))))
    (render-options pres (instance pres))))

(defmethod render-options ((pres object-presentation) instance)
  (declare (ignore instance pres))
  #| (<:tr
    (<:td :colspan 2 :align "center"
      (<ucw:input :type "submit" :action (ok pres) :value "Ok."))) |# )

(defaction ok ((o object-presentation) &optional (value (slot-value o 'instance)))
  (answer value))

(defmethod find-slot ((o object-presentation) slot-label)
  (find slot-label (slots o) :test #'string= :key #'label))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; inline objects are extremly similar to object-presentations
;;;; except that we assume they're being edited within the context of
;;;; some other and so don't get their own edit/delete/confirm
;;;; whatever buttons.

(defcomponent inline-object-presentation (object-presentation)
  ())

(defmethod render-options ((pres inline-object-presentation) instance)
  (declare (ignore instance))
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 'one line' objects

(defcomponent one-line-presentation (object-presentation)
  ((before :accessor before :initform "" :initarg :before
	   :documentation "Text to render before rendirng the slots.")
   (between :accessor between :initform " " :initarg :between
	    :documentation "Text to render between each slot.")
   (after :accessor after :initform "" :initarg after
	  :documentation "Text to render after all the slots have been rendered.")))

(defmethod present ((pres one-line-presentation))
  (<:as-is (before pres))
  (when (slots pres)
    (present-slot (first (slots pres)) (instance pres)))
  (dolist (slot (cdr (slots pres)))
    (<:as-is (between pres))
    (present-slot slot (instance pres)))
  (<:as-is (after pres)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; List

(defcomponent list-presentation (presentation)
  ((slots :accessor slots :initarg :slots)
   (editablep :accessor editablep :initform t :initarg :editablep)
   (edit-label :accessor edit-label :initform "Edit")
   (deleteablep :accessor deleteablep :initform t :initarg :deleteablep)
   (delete-label :accessor delete-label :initform "Delete")
   (instances :accessor instances)))

(defmethod initialize-instance :after ((l list-presentation) &rest initargs)
  (declare (ignore initargs))
  (setf (instances l) (get-all-instances l)))

(defmethod render-on ((res response) (l list-presentation))
  (present l))

(defgeneric get-all-instances (listing)
  (:documentation "Returns all the instances which should be viewable with LISTING.

This method is also used by relation-slot-presentations for the same reason."))

(defmethod present ((listing list-presentation))
  (<:table :class (css-class listing)
    (render-list-heading listing)
    (iterate
      (for element in (instances listing))
      (for index upfrom 0)
      (render-list-row listing element index))))

(defmethod render-list-heading ((listing list-presentation))
  (<:tr :class "presentation-list-heading-row"
    (<:th "")
    (dolist (slot (slots listing))
      (<:th :class "presentation-list-heading-cell"
        (<:as-html (label slot))))
    (<:th "")))
  
(defmethod render-list-row ((listing list-presentation) object index)
  (<:tr :class "item-row"
    (<:td :class "index-number-cell"
      (<:i (<:as-html index)))
    (dolist (slot (slots listing))
      (<:td :class "data-cell" (present-slot slot object)))
    (<:td :align "center" :valign "top"
      (when (editablep listing)
	(let ((object object))
	  (<ucw:input :type "submit"
		      :action (edit-from-listing listing object index)
		      :value (edit-label listing))))
      (<:as-is " ")
      (when (deleteablep listing)
	(let ((index index))
	  (<ucw:input :type "submit"
		      :action (delete-from-listing listing object index)
		      :value (delete-label listing)))))))

(defgeneric/cc create-from-listing (listing))

(defmethod/cc create-from-listing :after ((l list-presentation))
  (setf (instances l) (get-all-instances l)))

(defgeneric/cc delete-from-listing (listing item index))

(defmethod/cc delete-from-listing :after ((l list-presentation) item index)
  (declare (ignore item index))
  (setf (instances l) (get-all-instances l)))

(defgeneric/cc edit-from-listing (listing item index))

(defmethod/cc edit-from-listing :after ((l list-presentation) item index)
  (declare (ignore item index))
  (setf (instances l) (get-all-instances l)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Searching/Filtering

(defcomponent presentation-search (presentation)
  ((criteria :accessor criteria :initform '())
   (search-presentation :accessor search-presentation :initarg :search-presentation
			:documentation "The presentation object
			used in determining what the possible
			search options are.")
   (list-presentation :accessor list-presentation :initarg :list-presentation
		      :documentation "The presentation object used when showing the results.")))

(defgeneric applicable-criteria (presentation)
  (:method-combination nconc))

(defmethod applicable-criteria nconc ((search presentation-search))
  (let ((criteria '()))
    (dolist (slot (slots (search-presentation search)))
      (setf criteria (append criteria (applicable-criteria slot))))
    (cons (make-instance 'negated-criteria :presentation search)
	  criteria)))

(defcomponent criteria ()
  ((presentation :accessor presentation :initarg :presentation)))

(defaction add-criteria ((search presentation-search) (criteria criteria))
  (push criteria (criteria search)))

(defaction drop-criteria ((search presentation-search) (criteria criteria))
  (setf (criteria search) (delete criteria (criteria search))))

(defgeneric apply-criteria (criteria instance)
  (:method-combination and))

(defmethod valid-instances ((search presentation-search))
  (let ((valid '()))
    (dolist (i (get-all-instances search))
      (block apply-criteria
	(dolist (criteria (criteria search))
	  (unless (apply-criteria criteria i)
	    (return-from apply-criteria nil)))
	(push i valid)))
    valid))

(defcomponent search-results-list (list-presentation)
  ((search-presentation :accessor search-presentation)))

(defmethod render-on ((res response) (s presentation-search))
  (<:p "Results:")
  (let ((listing (list-presentation s)))
    (<:table
      (<:tr :class "presentation-list-heading-row"
        (<:th "")
	(dolist (slot (slots (list-presentation s)))
	  (<:th :class "presentation-list-heading-cell"
	    (<:as-html (label slot))))
	(<:th ""))
      (loop
         for object in (valid-instances s)
         for index upfrom 0
         do (<:tr :class "item-row"
              (<:td :class "index-number-cell" (<:i (<:as-html index)))
              (dolist (slot (slots (list-presentation s)))
                (<:td :class "data-cell" (present-slot slot object)))
              (<:td :align "center" :valign "top"
                (when (editablep listing)
                  (let ((object object))
                    (<ucw:input :type "submit"
                                :action (edit-from-search s object index)
                                :value (edit-label listing))))
                (<:as-is " ")
                (when (deleteablep listing)
                  (let ((index index))
                    (<ucw:input :type "submit"
                                :action (delete-from-search s object index)
                                :value (delete-label listing)))))))))
  (<:p "Search Criteria:")
  (<:ul
   (render-criteria res s)
   (<:li (<ucw:input :type "submit" :action (refresh-component s)
		     :value "update"))))

(defmethod render-criteria ((res response) (s presentation-search))
  (<:ul
   (dolist (c (criteria s))
     (<:li (render-on res c)
	   (let ((c c))
	     (<ucw:input :action (drop-criteria s c) :type "submit" :value "eliminate"))))
   (let ((new-criteria nil))
     (<:li "Add Criteria: "
       (<ucw:select :accessor new-criteria
         (dolist (criteria (applicable-criteria s))
	   (<ucw:option :value criteria (<:as-html (label criteria)))))
       (<ucw:input :type "submit" :action (add-criteria s new-criteria)
		   :value "add")))))

(defgeneric/cc edit-from-search (search object index))

(defgeneric/cc delete-from-search (search object index))

;;;; meta criteria

(defcomponent negated-criteria (criteria)
  ((criteria :accessor criteria :initform nil)))

(defmethod label ((n negated-criteria)) "Not:")

(defmethod render-on ((res response) (n negated-criteria))
  (<:p "Not: "
       (when (criteria n)
	 (render-on res (criteria n))))
  (let ((new-criteria nil))
    (<:p "Set Criteria: "
      (<ucw:select :accessor new-criteria
        (dolist (criteria (applicable-criteria (presentation n)))
	  (<ucw:option :value criteria (<:as-html (label criteria)))))
      (<ucw:input :type "submit" :action (setf (criteria n) new-criteria)
		  :value "add"))))

(defmethod apply-criteria and ((n negated-criteria) instance)
  (if (criteria n)
      (not (apply-criteria (criteria n) instance))
      t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Slot presentations

(defcomponent slot-presentation (presentation)
  ((label :accessor label :initarg :label)
   (label-plural :accessor label-plural :initarg :label-plural)
   (getter :accessor getter :initarg :getter
	   :documentation "A function used for getting the
	   current value of the object. It will be passed the
	   objcet and must return the current value.")
   (setter :accessor setter :initarg :setter
	   :documentation "A function used for updatig the value of
	   the underlying object. It will be passed the new
	   value and the object (in that order).")
   (editablep :accessor editablep :initarg :editablep :initform t)
   (print-object-label)))

(defmethod print-object ((s slot-presentation) stream)
  (if *print-readably*
      (call-next-method)
      (print-unreadable-object (s stream :type t :identity t)
        (princ (label s) stream)
        (princ " (" stream)
        (princ (slot-value s 'print-object-label) stream)
        (princ ")" stream))))

(defgeneric present-slot (slot instance))

(defmethod initialize-instance :after ((presentation slot-presentation)
				       &key slot-name getter setter &allow-other-keys)
  (if slot-name
      (setf (slot-value presentation 'print-object-label) slot-name)
      (setf (slot-value presentation 'print-object-label) getter))
  (when slot-name
    (assert (not (or getter setter))
	    (slot-name getter setter)
	    "Can't specify :GETTER and/or :SETTER alnog with :SLOT-NAME.")
    (setf (getter presentation) (lambda (object)
				  (when (slot-boundp object slot-name)
				    (slot-value object slot-name)))
	  (setter presentation) (lambda (value object)
				  (setf (slot-value object slot-name) value)))))

(defvar *presentation-slot-type-mapping* (make-hash-table :test 'eql))

(defun register-slot-type-mapping (name class-name)
  (setf (gethash name *presentation-slot-type-mapping*) class-name))

(defmacro defslot-presentation (name supers slots &rest options)
  `(progn
     (defcomponent ,name ,(or supers `(slot-presentation))
       ,slots
       ,@(remove :type-name options :key #'car))
     ,(let ((type-name (assoc :type-name options)))
	(when type-name
	`(register-slot-type-mapping ',(second type-name) ',name)))
     ',name))

(defgeneric presentation-slot-value (slot instance)
  (:method ((slot slot-presentation) instance)
    (funcall (getter slot) instance)))

(defgeneric (setf presentation-slot-value) (value slot instance)
  (:method (value (slot slot-presentation) instance)
    (funcall (setter slot) value instance)))

(defmethod applicable-criteria nconc ((s slot-presentation))
  nil)

(defmacro criteria-for-slot-presentation (slot &body criteria-clauses)
  (rebinding (slot)
    `(list
      ,@(mapcar (lambda (criteria-clause)
		  (let ((criteria-clause (ensure-list criteria-clause)))
		    `(make-instance ',(first criteria-clause)
				    ,@(cdr criteria-clause)
				    :presentation ,slot)))
		criteria-clauses))))

(defmacro defslot-critera (class-name supers slots &key label apply-criteria)
  (with-unique-names (obj instance)
    (list
     'progn
     `(defcomponent ,class-name ,supers ,slots)
     (when label
       `(defmethod label ((,obj ,class-name))
          (format nil ,label (label (presentation ,obj)))))

     (when apply-criteria
       `(defmethod apply-criteria and ((,obj ,class-name) ,instance)
          (funcall ,apply-criteria
                   ,obj
                   ,instance
                   (presentation-slot-value (presentation ,obj) ,instance))))
     `(quote ,class-name))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Boolean

(defslot-presentation boolean-slot-presentation ()
  ()
  (:type-name boolean))

(defmethod present-slot ((slot boolean-slot-presentation) instance)
  (<ucw:input :type "checkbox" :accessor (presentation-slot-value slot instance)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; strings

(defslot-presentation string-slot-presentation ()
  ((max-length :accessor max-length :initarg :max-length :initform nil)
   (size :accessor size :initarg :size :initform nil))
  (:type-name string))

(defmethod present-slot ((slot string-slot-presentation) instance)
  (if (editablep slot)
      (<ucw:input :type "text"
		  :accessor (presentation-slot-value slot instance)
		  :size (or (size slot)
			    (if (string= "" (presentation-slot-value slot instance))
				(size slot)
				(+ 3 (length (presentation-slot-value slot instance)))))
		  :maxlength (max-length slot))
      (<:as-html (presentation-slot-value slot instance))))

;;;; Critera

(defmethod applicable-criteria nconc ((s string-slot-presentation))
  (criteria-for-slot-presentation s
    string-starts-with
    string-contains
    string-ends-with))

(defcomponent string-criteria (criteria)
  ((search-text :accessor search-text :initform nil)))

(defmethod render-on ((res response) (criteria string-criteria))
  (<:as-html (label criteria) " ")
  (<ucw:input :type "text" :accessor (search-text criteria) :size 10))

(defslot-critera string-contains (string-criteria)
  ()
  :label "~A contains:"
  :apply-criteria (lambda (criteria instance slot-value)
		    (declare (ignore instance))
		    (and (<= (length (search-text criteria)) (length slot-value))
			 (search (search-text criteria) slot-value :test #'char-equal))))

(defslot-critera string-starts-with (string-contains)
  ()
  :label "~A starts with:"
  :apply-criteria (lambda (criteria instance slot-value)
                    (declare (ignore instance))
		    (and (<= (length (search-text criteria)) (length slot-value))
			 (= 0 (or (search (search-text criteria) slot-value
					  :test #'char-equal)
				  -1)))))

(defslot-critera string-ends-with (string-contains)
  ()
  :label "~A ends with:"
  :apply-criteria (lambda (criteria instance slot-value)
		    (declare (ignore instance))
		    (and  (<= (length (search-text criteria)) (length slot-value))
			  (= (- (length slot-value) (length (search-text criteria)))
			     (or (search (search-text criteria) slot-value
					 :from-end t
					 :test #'char-equal)
				 -1)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; numbers

(defslot-presentation number-slot-presentation ()
  ((min-value :accessor min-value :initarg :min-value :initform nil)
   (max-value :accessor max-value :initarg :max-value :initform nil)))

(defcomponent number-criteria (criteria)
  ((number-input :accessor number-input :initform nil)))

(defmethod applicable-criteria nconc ((s number-slot-presentation))
  (criteria-for-slot-presentation s
    number-less-than
    number-greater-than
    number-equal-to))

(defmacro defnumber-criteria (name &key label render-on-prefix apply-criteria)
  `(progn
     (defslot-critera ,name (number-criteria)
       ()
       :label ,label
       :apply-criteria (lambda (criteria instance slot-value)
			 (declare (ignore instance))
			 (if (numberp slot-value)
			     (if (number-input criteria)
				 (funcall ,apply-criteria slot-value (number-input criteria))
				 t)
			     nil)))

     (defmethod render-on ((res response) (obj ,name))
       (<:as-html (format nil ,render-on-prefix (label (presentation obj))))
       (<ucw:input :type "text"
		   :reader (or (number-input obj) "")
		   :writer (lambda (v)
			     (unless (string= "" v)
			       (let ((n (parse-float v)))
				 (when n
				   (setf (number-input obj) n)))))))))

(defnumber-criteria number-equal-to
  :apply-criteria (lambda (slot-value number-input)
		    (= slot-value number-input))
  :label "~A is equal to:"
  :render-on-prefix "~A = ")

(defnumber-criteria number-less-than
  :apply-criteria (lambda (slot-value number-input)
		    (< slot-value number-input))
  :label "~A is less than:"
  :render-on-prefix "~A < ")

(defnumber-criteria number-greater-than
  :apply-criteria (lambda (slot-value number-input)
		    (> slot-value number-input))
  :label "~A is greater than:"
  :render-on-prefix "~A > ")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Integers

(defslot-presentation integer-slot-presentation (number-slot-presentation)
  ()
  (:type-name integer))

(defmethod presentation-slot-value ((slot integer-slot-presentation) instance)
  (declare (ignore instance))
  (or (call-next-method) ""))

(defmethod (setf presentation-slot-value) ((value string) (slot integer-slot-presentation) instance)
  (unless (string= "" value)
    (let ((i (parse-integer value :junk-allowed t)))
      (when i
	(setf (presentation-slot-value slot instance) i)))))

(defmethod present-slot ((slot integer-slot-presentation) instance)
  (if (editablep slot)
      (<ucw:input :type "text"
		  :accessor (presentation-slot-value slot instance))
      (<:as-html (presentation-slot-value slot instance))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Reals

(defcomponent real-slot-presentation (number-slot-presentation)
  ())

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Currency (double precision reals)

(defslot-presentation currency-slot-presentation (real-slot-presentation)
  ((as-money-p :accessor as-money-p :initarg :as-money-p :initform nil))
  (:type-name currency))

(defmethod (setf presentation-slot-value) ((value string) (c currency-slot-presentation) instance)
  (let ((*read-eval* nil))
    (unless (string= "" value)
      (let ((value (read-from-string value)))
	(when (numberp value)
	  (setf (presentation-slot-value c instance) value))))))

(defmethod present-slot ((currency currency-slot-presentation) instance)
  (if (editablep currency)
      (<ucw:input :type "text" :size 10
		  :accessor (presentation-slot-value currency instance))
      (<:as-html (format nil (if (as-money-p currency)
				 "$~$"
				 "~D")
			 (presentation-slot-value currency instance)) )))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; dates and times

(defslot-presentation timestamp-slot-presentation (slot-presentation)
  ()
  (:type-name timestamp))

(defmacro deftimestamp-slot-accessor (accessor time-accessor nth-value make-time-arg)
  (let ((accessor-name (intern (strcat '#:timestamp-slot- accessor))))
    `(progn
       (defgeneric ,accessor-name (slot instance))
       (defgeneric (setf ,accessor-name) (value slot instance))
       (defmethod ,accessor-name ((slot timestamp-slot-presentation) instance)
	 (when (presentation-slot-value slot instance)
	   (nth-value ,nth-value (,time-accessor (presentation-slot-value slot instance)))))
       (defmethod (setf ,accessor-name) ((value integer) (slot timestamp-slot-presentation) instance)
	 (if (presentation-slot-value slot instance)
	     (setf (presentation-slot-value slot instance)
		   (make-time ,make-time-arg value :defaults (presentation-slot-value slot instance)))
	     (setf (presentation-slot-value slot instance) (make-time ,make-time-arg value))))
       (defmethod (setf ,accessor-name) ((value string) (slot timestamp-slot-presentation) instance)
         (setf (,accessor-name slot instance)
               (if (string= "" value)
                   nil
                   (parse-integer value))))
       (defmethod (setf ,accessor-name) ((value null) (slot timestamp-slot-presentation) instance)
         (setf (presentation-slot-value slot instance) nil)))))

(deftimestamp-slot-accessor second time-hms 2 :second)
(deftimestamp-slot-accessor minute time-hms 1 :minute)
(deftimestamp-slot-accessor hour time-hms 0 :hour)
(deftimestamp-slot-accessor year time-ymd 0 :year)
(deftimestamp-slot-accessor month time-ymd 1 :month)
(deftimestamp-slot-accessor day time-ymd 2 :day)

(defslot-presentation ymd-slot-presentation (timestamp-slot-presentation)
  ()
  (:type-name date))

(defmethod present-slot ((slot ymd-slot-presentation) instance)
  (if (editablep slot)
      (<:progn
        (<ucw:input :class (css-class slot) :type "text" :size 2
                    :accessor (timestamp-slot-day slot instance))
        "/"
        (<ucw:input :class (css-class slot) :type "text" :size 2
                    :accessor (timestamp-slot-month slot instance))
        "/"
        (<ucw:input :class (css-class slot) :type "text" :size 4
                    :accessor (timestamp-slot-year slot instance)))
      (if (presentation-slot-value slot instance)
	  (<:progn
	    (<:as-html (timestamp-slot-day slot instance))
	    "/"
	    (<:as-html (timestamp-slot-month slot instance))
	    "/"
	    (<:as-html (timestamp-slot-year slot instance)))
	  (<:as-html "---"))))

(defmethod applicable-criteria nconc ((slot ymd-slot-presentation))
  (criteria-for-slot-presentation slot
    date-before-criteria))

(defslot-critera date-before-criteria (criteria)
  ((target :accessor target))
  :label "Date Before:")

(defmethod render-on ((res response) (dbc date-before-criteria))
  (<:as-html "Date Before: "))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Relations

(defcomponent relation-slot-presentation (slot-presentation)
  ((presentation :accessor presentation
		 :initarg :presentation
		 :documentation "The class of presentation
		 objects used to fill the options of a select
		 tag.")
   (search-presentation :accessor search-presentation
			:initarg :search-presentation
			:initform nil)
   (allow-nil-p :accessor allow-nil-p
		:initarg :allow-nil-p
		:initform t
		:documentation "Can this relation not exist.")))

(defmethod presentation ((slot relation-slot-presentation))
  (with-slots (presentation)
      slot
    (if (or (symbolp presentation)
	    (consp presentation))
	(setf presentation (apply #'make-instance (ensure-list presentation)))
	presentation)))

(defgeneric get-foreign-instances (pres instance))

(defcomponent relation-criteria (criteria presentation-search)
  ((criteria :accessor criteria :initform '())))

(defmethod search-presentation ((criteria relation-criteria))
  (or (search-presentation (presentation criteria))
      (presentation (presentation criteria))))

;;;; One-Of

(defslot-presentation one-of-presentation (relation-slot-presentation)
  ((none-label :initarg :none-label :accessor none-label
	       :initform "none"))
  (:type-name one-of))

(defmethod present-slot ((slot one-of-presentation) instance)
  (if (editablep slot)
      (<ucw:select :accessor (presentation-slot-value slot instance)
        (when (allow-nil-p slot)
	  (<ucw:option :value nil (<:as-html (none-label slot))))
	(dolist (option (get-foreign-instances (presentation slot) instance))
	  (setf (instance (presentation slot)) option)
	  (<ucw:option :value option (present (presentation slot)))))
      (if (presentation-slot-value slot instance)
	  (progn
	    (setf (instance (presentation slot)) (presentation-slot-value slot instance))
	    (present (presentation slot)))
	  (<:as-html "--"))))

(defmethod applicable-criteria nconc ((slot one-of-presentation))
  (criteria-for-slot-presentation slot
    one-of-criteria
    one-of-not-null))

(defslot-critera one-of-criteria (relation-criteria)
  ())

(defmethod label ((ooc one-of-criteria))
  (strcat (label (presentation ooc)) " with:"))

(defmethod render-on ((res response) (ooc one-of-criteria))
  (<:as-html (label (presentation ooc)) " with:")
  (render-criteria res ooc))

(defmethod apply-criteria and ((ooc one-of-criteria) instance)
  (let ((nested-instance (presentation-slot-value (presentation ooc) instance))
	(criteria (criteria ooc)))
    (if criteria
	(if nested-instance
	    (dolist (c (criteria ooc) t)
	      (unless (apply-criteria c nested-instance)
		(return-from apply-criteria nil)))
	    nil)
	t)))

(defslot-critera one-of-not-null (criteria)
  ())

(defmethod label ((oonn one-of-not-null))
  (strcat (label (presentation oonn)) " exists."))

(defmethod apply-criteria and ((oonn one-of-not-null) instance)
  (not (null (presentation-slot-value (presentation oonn) instance))))

(defmethod render-on ((res response) (oonn one-of-not-null))
  (<:as-html (label (presentation oonn)) " exists."))

;;;; Some-Of

(defslot-presentation some-of-presentation (relation-slot-presentation)
  ()
  (:type-name some-of))

(defmethod present-slot ((slot some-of-presentation) instance)
  (<:ul
   (if (presentation-slot-value slot instance)
       (loop
          for option in (presentation-slot-value slot instance)
          for index upfrom 0
          do (let ((option option) ;; loop changes the values, it does
                                   ;; not create fresh bindings
                   (index index))
               (<:li
                 (<:table
                   (<:tr
                     (<:td (setf (instance (presentation slot)) option)
                           (present (presentation slot)))
                     (when (editablep slot)
                       (<:td :align "left" :valign "top"
                         (<ucw:input :type "submit"
                                     :action (delete-element slot instance option index)
                                     :value (concatenate 'string "Delete " (label slot))))))))))
       (<:li "None."))
   (render-add-new-item slot instance)))

(defmethod render-add-new-item ((slot some-of-presentation) instance)
  (let ((new-object nil)
	(foreign-instances (get-foreign-instances (presentation slot) instance)))
    (when (and foreign-instances (editablep slot))
      (<:li "Add: "
        (<ucw:select :accessor new-object
	  (dolist (option foreign-instances)
	    (setf (instance (presentation slot)) option)
	    (<ucw:option :value option (present (presentation slot)))))
	(<ucw:input :type "submit"
		    :action (add-element slot instance new-object)
		    :value "Add")))))

(defaction add-element ((some-of some-of-presentation) instance item)
  (push item (presentation-slot-value some-of instance)))

(defaction delete-element ((some-of some-of-presentation) instance item index)
  (let ((nth (nth index (presentation-slot-value some-of instance))))
    (unless (eq nth item)
      (error "Attempting to delete the ~Dth item, which should be ~S, but the ~Dth item is actually ~S."
	     index item index nth))
    (setf (presentation-slot-value some-of instance)
	  (iterate
	    (for element in (presentation-slot-value some-of instance))
	    (for i upfrom 0)
	    (unless (= index i)
	      (collect element))))))

(defmethod applicable-criteria nconc ((slot some-of-presentation))
  (criteria-for-slot-presentation slot
    some-of-any
    some-of-all))

(defslot-critera some-of-criteria (relation-criteria)
  ())

(defmethod render-on ((res response) (soa some-of-criteria))
  (<:as-html (label soa))
  (render-criteria res soa))

(defmacro defsome-of-criteria (name supers slots &key label apply-criteria)
  (with-unique-names (obj)
    `(progn
       (defslot-critera ,name ,supers ,slots)
       (defmethod label ((,obj ,name))
	 (format nil ,label (label (presentation ,obj))))
       (defmethod apply-criteria and ((,obj ,name) instance)
	 (let ((nested-instances (presentation-slot-value (presentation ,obj) instance))
	       (criteria (criteria ,obj)))
	   (if criteria
	       (if nested-instances
		   (funcall ,apply-criteria (criteria ,obj) nested-instances)
		   nil)
	       t))))))

(defsome-of-criteria some-of-any (some-of-criteria)
  ()
  :label "Any ~A with:"
  :apply-criteria (lambda (criteria nested-instances)
		    ;; return T if any nested-instance meets all of criteria
		    (some (lambda (instance)
			    (every (lambda (criteria)
				     (apply-criteria criteria instance))
				   criteria))
			  nested-instances)))

(defsome-of-criteria some-of-all (some-of-criteria)
  ()
  :label "All ~A with:"
  :apply-criteria (lambda (criteria nested-instances)
		    ;; return T only if every nested-instances meets
		    ;; all of our criteria
		    (every (lambda (instance)
			     (every (lambda (criteria)
				      (apply-criteria criteria instance))
				    criteria))
			   nested-instances)))

;;;; An-Object

(defslot-presentation an-object-presentation (one-of-presentation)
  ()
  (:type-name an-object))

(defmethod present-slot ((slot an-object-presentation) instance)
  (if (presentation-slot-value slot instance)
      (progn
	(setf (instance (presentation slot)) (presentation-slot-value slot instance))
	(present (presentation slot))
	(<ucw:input :type "submit" :action (delete-an-object slot instance)
                    :value (concatenate 'string "Delete " (label slot))))
      (<ucw:input :type "submit" :action (create-an-object slot instance) :value "Create")))

(defaction delete-an-object ((slot an-object-presentation) instance)
  (setf (presentation-slot-value slot instance) nil))

(defaction create-an-object ((slot an-object-presentation) instance)
  (let ((obj (make-new-instance (presentation slot) instance)))
    (format t "Setting (presentation-slot-value ~S ~S) to ~S.~%" slot instance obj)
    (setf (presentation-slot-value slot instance) obj)))

;;;; Some-Objects

(defslot-presentation some-objects-presentation (some-of-presentation)
  ()
  (:type-name some-objects))

(defmethod render-add-new-item ((slot some-objects-presentation) instance)
  (when (editablep slot)
    (<:li (<ucw:input :type "submit"
		      :action (add-an-object slot instance)
		      :value "Add new object."))))

(defgeneric make-new-instance (presentation instance)
  (:documentation "Create an new instance suitable for
  PRESENTATION which will be added to INSTANCE (according to
  PRESENTATION)."))

(defaction add-an-object ((slot some-objects-presentation) instance)
  (push (make-new-instance (presentation slot) instance) (presentation-slot-value slot instance)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Convience macros/functions

(defmacro slot-presentations (&rest slot-specs)
  `(list ,@(mapcar (lambda (slot)
		     (let ((class-name (gethash (car slot) *presentation-slot-type-mapping*)))
		       (if class-name
			   `(make-instance ',class-name ,@(cdr slot))
			   (error "Unknown slot type ~S." (car slot)))))
		   slot-specs)))

(defmacro defpresentation (name supers slots &rest default-initargs)
  `(defcomponent ,name ,supers
     ()
     (:default-initargs
       ,@(when slots `(:slots (slot-presentations ,@slots)))
       ,@default-initargs)))