+++ /dev/null
-;;;; -*- lisp -*-
-
-(in-package :mewa)
-
-(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))
- (setf (presentation-slot-value slot instance) nil))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; 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) (parse-integer value))))))
-
-(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)
- ()
- (: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 (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)))
-
HCoop / clinton / lisp-on-lines.git / blobdiff