(defsystem :lisp-on-lines
:components ((:static-file "lisp-on-lines.asd")
(:module :patches
- :components ((:file "yaclml")))
+ :components ((:file "yaclml")
+ (:file "ucw")))
(:module :src
:components ((:file "packages")
(:file "special-initargs")
(:file "defdisplay")
(:file "standard-display")
(:file "standard-occurence")
- (:file "standard-attributes")
- (:file "dojo-attributes")
(:file "standard-wrappers")
- (:file "relational-attributes")
-
(:file "lines")
-
- (:file "backwards-compat")
+ (:file "defdescription")
(:module :attributes
-
- :components ((:file "numbers"))))
+ :components (
+ (:file "standard-attributes")
+ (:file "numbers")
+ (:file "relational-attributes")
+ (:file "dojo-attributes"))
+ :serial t)
+ (:module :components
+ :components ((:file "crud"))))
:serial t))
:serial t
:depends-on (:arnesi :ucw :meta-model :split-sequence :contextl :cl-ppcre :cl-fad))
(defattribute integer-attribute (number-attribute integer-field)
()
(:in-layer editor)
+ (:default-initargs
+ :default-value ""
+ :default-value-predicate (complement #'numberp))
(:type-name integer))
()
(:type-name currency))
-(defdisplay
- ((currency currency-attribute) object)
- (<:as-html "$")
- (call-next-method))
(defdisplay :in-layer editor
((currency currency-attribute) object)
;;
(define-layered-method attribute-value (object (attribute has-a))
- (meta-model:explode-foreign-key object (slot-name attribute) :nilp t))
+ (multiple-value-bind (obj key class)
+ (meta-model:explode-foreign-key object (slot-name attribute) :nilp t)
+ (if (persistentp object)
+ obj
+ (first (select class
+ :where [= [slot-value class key] (call-next-method)]
+ :flatp t
+ )))))
(define-layered-method (setf attribute-value) ((value standard-object) object (attribute has-a))
(let ((val (slot-value value (find-if (curry #'primary-key-p value) (list-keys value)))))
:time-element
:time+
:date-element)
-
- (:shadow
- :present
- :present-slot
- :presentation
- :instance
- :slot-presentation
- :integer-slot-presentation
- :string-slot-presentation
- :object-presentation
- :one-line-presentation
- :presentation-slot-value
- :get-foreign-instances)
(:export
;;;; CLSQL meta-model/default attributes definers
:as-table
;;;; "Lines", the newest creation.
:defline
- :line-in
- :line-out
-
+ ;;;; A macro shortcut for creating ucw actions
:action
-
-
- ;;;;a wrapper for calling make-presentation
- :call-view
- :present-view
- :slot-view
- :present-slot-view
- :make-view
- ;;;; Ajax
- :auto-complete
- :call-auto-complete
;;;; Mewa Exports
- :mewa ;the superclass of all mewa-presentations
- :make-presentation
- :call-presentation
-
:find-occurence
;;attributes
:set-default-attributes
:set-attribute
:find-attribute
- :perform-set-attributes
- ;;
- :perform-set-attribute-properties
- :define-attributes
-
- ;; presentation objects
- :mewa-object-presentation
- :mewa-one-line-presentation
- :mewa-list-presentation
- :mewa-search-presentation
- :mewa-presentation-search
-
- :editablep
- :global-properties
- ;; SLOT presentations
-
- :mewa-relation-slot-presentation
- :mewa-string-slot-presentation
- :has-many-slot-presentation
- :has-a
- :has-many
- :has-very-many
- :many-to-many
-
- ;; CRUD
- :instance-is-stored-p
;;;; Meta Model Exports))
:define-meta-model
+++ /dev/null
-(declaim (optimize (speed 0) (space 3) (safety 0)))
-(in-package :lisp-on-lines)
-
-
-(defmethod render ((self mewa))
- (lol::present self))
-
-(defaction edit-instance ((self mewa))
- (call-presentation (instance self) :type :editor))
-
-;;;one-line objects
-(defcomponent mewa-one-line-presentation (mewa lol::one-line-presentation)
- ()
- (:default-initargs
- :attributes-getter #'one-line-attributes-getter
- :global-properties '(:editablep nil)))
-
-(defmethod one-line-attributes-getter ((self mewa))
- (or (meta-model::find-slots-of-type (instance self))
- (meta-model::list-keys (instance self))))
-
-;;;objects
-(defcomponent mewa-object-presentation (mewa lol::object-presentation)
- ((instance :accessor instance :initarg :instance :initform nil)))
-
-(defcomponent mewa-viewer (mewa-object-presentation)
- ()
- (:default-initargs
- :global-properties '(:editablep nil)))
-
-(defcomponent mewa-editor (mewa-object-presentation)
- ()
- (:default-initargs
- :global-properties '(:editablep t)))
-
-(defcomponent mewa-creator (mewa-editor)
- ())
-
-(defmethod present ((pres mewa-object-presentation))
- (<:table :class (css-class pres)
- (dolist (slot (slots pres))
- (<:tr :class "presentation-slot-row"
- (present-slot-as-row pres slot))))
- (render-options pres (instance pres)))
-
-(defmethod present-slot-as-row ((pres mewa-object-presentation) (slot slot-presentation))
- (<:td :class "presentation-slot-label" (<:as-html (label slot)))
- (<:td :class "presentation-slot-value" (present-slot slot (instance pres))))
-
-
-(defcomponent two-column-presentation (mewa-object-presentation) ())
-
-(defmethod present ((pres two-column-presentation))
-
- (<:table :class (css-class pres)
- (loop for slot on (slots pres) by #'cddr
- do
- (<:tr :class "presentation-slot-row"
- (<:td :class "presentation-slot-label"
- (<:as-html (label (first slot))))
- (<:td :class "presentation-slot-value"
- (present-slot (first slot) (instance pres)))
- (when (second slot)
- (<:td :class "presentation-slot-label"
- (<:as-html (label (second slot))))
- (<:td :class "presentation-slot-value"
- (present-slot (second slot) (instance pres))))))
- (render-options pres (instance pres))))
-
-
-;;;lists
-(defcomponent mewa-list-presentation (mewa list-presentation)
- ((instances :accessor instances :initarg :instances :initform nil)
- (instance :accessor instance)
- (select-label :accessor select-label :initform "select" :initarg :select-label)
- (selectablep :accessor selectablep :initform t :initarg :selectablep)
- (deleteablep :accessor deletablep :initarg :deletablep :initform nil)
- (viewablep :accessor viewablep :initarg :viewablep :initform nil)))
-
-(defaction select-from-listing ((listing mewa-list-presentation) object index)
- (answer object))
-
-(defmethod render-list-row ((listing mewa-list-presentation) object index)
- (<:tr :class "item-row"
- (<: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))))
- (when (selectablep listing)
- (let ((index index))
- (<ucw:input :type "submit"
- :action (select-from-listing listing object index)
- :value (select-label listing))))
- (when (viewablep listing)
- (let ((index index))
- (<ucw:input :type "submit"
- :action (call-component listing (make-presentation object))
- :value "view"))))
- (dolist (slot (slots listing))
- (<:td :class "data-cell" (present-slot slot object)))
- (<:td :class "index-number-cell")))
-
-(defmethod get-all-instances ((self mewa-list-presentation))
- (instances self))
-
-
-;;;; * Presentation Searches
-
-
-;;;; ** "search all fields" criteria
-
-(defgeneric search-expr (criteria instance)
- (:documentation "Return ready to apply criteria.
- to do with What it is backend dependent."))
-
-(defmacro def-search-expr (((self criteria-type)) (model-expr &body body))
- `(defmethod search-expr ((,self ,criteria-type) instance)
- (,model-expr
- instance
- (slot-name (presentation ,self))
- ,@body)))
-
-(defmethod search-expr ((self negated-criteria) instance)
- (when (criteria self)
- (meta-model:expr-not
- instance
- (search-expr (criteria self) instance))))
-
-(def-search-expr ((self string-starts-with))
- (meta-model:expr-starts-with (search-text self)))
-
-(def-search-expr ((self string-ends-with))
- (meta-model:expr-ends-with (search-text self)))
-
-(def-search-expr ((self string-contains))
- (meta-model:expr-contains (search-text self)))
-
-(def-search-expr ((self number-less-than))
- (meta-model:expr-< (number-input self)))
-
-(def-search-expr ((self number-greater-than))
- (meta-model:expr-> (number-input self)))
-
-(def-search-expr ((self number-equal-to))
- (meta-model:expr-= (number-input self)))
-
-
-
-(defcomponent mewa-presentation-search (presentation-search)
- ((display-results-p :accessor display-results-p :initarg :display-results-p :initform nil)
- (criteria-input :accessor criteria-input :initform "")
- (new-criteria :accessor new-criteria :initform nil)))
-
-(defmethod instance ((self mewa:mewa-presentation-search))
- (instance (search-presentation self)))
-
-(defmethod search-expr ((self mewa:mewa-presentation-search) instance)
- (apply #'meta-model:expr-and instance
- (mapcan (lambda (c) (let ((e (search-expr c instance)))
- (if (listp e) e (list e))))
- (criteria self))))
-
-(defmethod search-query ((self mewa:mewa-presentation-search))
- (search-expr self (instance self)))
-
-(defmethod valid-instances ((self mewa:mewa-presentation-search))
- (meta-model:select-instances (instance self) (search-query self)))
-
-(defmethod get-all-instances ((self mewa-presentation-search))
- (meta-model:select-instances (instance self)))
-
-(defmethod ok ((self mewa-presentation-search) &optional arg)
- (declare (ignore arg))
- (setf (instances (list-presentation self)) (valid-instances self))
- (setf (display-results-p self) t))
-
-
-(defmethod set-search-input-for-criteria ((criteria criteria) (input t))
- (error "No search-input-for-criteria method for ~A : ~A" criteria input))
-
-(defmethod set-search-input-for-criteria ((c string-criteria) input)
- (setf (search-text c) input))
-
-(defmethod set-search-input-for-criteria ((c negated-criteria) i)
- nil)
-
-
-(defmethod mewa-add-criteria ((self component) (criteria criteria))
- (set-search-input-for-criteria criteria (criteria-input self))
- (add-criteria self criteria))
-
-(defmethod find-default-criteria (c mewa-string-slot-presentation)
- 'string-contains)
-
-(defmethod render-criteria ((res response) (s mewa-presentation-search))
- (setf (criteria-input s) "")
- (<:ul
- (dolist (c (criteria s))
- (<:li (render-on res c)
- (let ((c c))
- (<ucw:input :action (drop-criteria s c) :type "submit" :value "eliminate"))))
- (<:li
- "Search For: "
- (<ucw:input :type "text" :accessor (criteria-input s))
- " Using : "
- (<ucw:select :accessor (new-criteria s)
- (dolist (criteria (applicable-criteria s))
- (<ucw:option :value criteria (<:as-html (label criteria)))))
- (<ucw:input :type "submit" :action (mewa-add-criteria s (new-criteria s))
- :value "add"))))
-
-(defmethod submit-search ((s mewa-presentation-search))
- (with-slots (criteria-input) s
-
- (unless (or (null criteria-input)
- (string-equal "" (remove #\Space criteria-input)))
-
- (mewa-add-criteria s (new-criteria s)))
-
- (ok s)))
-
-(defmethod render-on ((res response) (self mewa-presentation-search))
- ;(<:as-html (search-query self))
- (render-criteria res self)
- (<ucw:input :type "submit" :value "Search" :action (submit-search self))
- (when (display-results-p self)
- (let ((listing (list-presentation self)))
- (setf
- (slot-value listing 'ucw::calling-component) (slot-value self 'ucw::calling-component)
- (slot-value listing 'ucw::place) (slot-value self 'ucw::place)
- (slot-value listing 'ucw::continuation) (slot-value self 'ucw::continuation))
-
- (render-on res listing))))
-
-
-;;;;
-(defcomponent dont-show-unset-slots ()())
-
-(defmethod slots :around ((self dont-show-unset-slots))
- (remove-if-not #'(lambda (s) (let ((s (presentation-slot-value s (instance self))))
- (and s (not (equal "" s)))))
- (call-next-method)))
\ No newline at end of file
+++ /dev/null
-;; i know this is horrible, but it works wonders.
-(declaim (optimize (speed 0) (space 3) (safety 0)))
-
-
-(in-package :lisp-on-lines)
-
-
-;;;; I dont think i'm using these anymore.
-(defun multiple-value-funcall->list (function &rest args)
- "The function to be called by m-v-bf"
- (multiple-value-call #'list (apply function args)))
-
-(defmacro multiple-value-bindf (vars form &body body)
- "Like M-V-B, only it works in actions. form must be a function call"
- `(destructuring-bind ,vars
- (multiple-value-funcall->list #',(car form) ,@(cdr form))
- ,@body))
-
-
-;;;; ** Textarea Slot Presentation
-
-(defslot-presentation text-slot-presentation ()
- ((rows :initarg :rows :accessor rows :initform 5)
- (columns :initarg :columns :accessor columns :initform 40)
- (escape-html-p :initarg :escape-html-p :accessor escape-html-p :initform nil)
- (convert-newlines-p :initarg :convert-newlines-p :accessor convert-newlines-p :initform nil))
- (:type-name text))
-
-(defmethod present-slot ((slot text-slot-presentation) instance)
- (flet ((maybe-convert-newline-and-escape-html-then-print ()
- (let ((string (if (convert-newlines-p slot)
- (with-output-to-string (new-string)
- (with-input-from-string
- (s (presentation-slot-value slot instance))
- (loop for line = (read-line s nil)
- while line
- do (format new-string "~A~A" line "<br/>"))))
- (presentation-slot-value slot instance))))
- (if (escape-html-p slot)
- (<:as-html string)
- (<:as-is string)))))
-
- (if (editablep slot)
- (<ucw:textarea
- :accessor (presentation-slot-value slot instance)
- :reader (or (presentation-slot-value slot instance)
- "")
- :rows (rows slot)
- :cols (columns slot))
- (when (presentation-slot-value slot instance)
- (maybe-convert-newline-and-escape-html-then-print)))))
-
-
-(defcomponent mewa-slot-presentation ()
- ((validate-functions :accessor validate-functions :initform (list (constantly t)))
- (slot-name :accessor slot-name
- :initarg :slot-name
- :documentation
- "The name of the slot being accessed")
- (fill-gaps-only-p :accessor fill-gaps-only-p
- :initarg :fill-gaps-only-p
- :initform nil
- :documentation
- "When nil, the instance is syncronised with the database.
-When T, only the default value for primary keys and the joins are updated.")
- (show-label-p :accessor show-label-p :initarg :show-label-p :initform t)
- (creatablep :accessor creatablep :initarg :creatablep :initform t))
- (:documentation "The superclass of all Mewa slot presentations"))
-
-
-
-;;;; this has to be in the eval when i would think
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun generate-slot-presentation-definition-for-type (type)
- (let* ((u-name (intern (format nil "~A-SLOT-PRESENTATION" type)))
- (sp-name (intern (format nil "MEWA-~A" u-name)))
- (t-name (intern (format nil "MEWA-~A" type))))
- `(defslot-presentation ,sp-name (,u-name mewa-slot-presentation)
- ()
- (:type-name ,t-name)))))
-
-(defmacro define-base-mewa-presentations (&body types)
- "Define the mewa-slot-presentations by subclassing the base UCW ones"
- `(progn ,@(mapcar #'generate-slot-presentation-definition-for-type
- types)))
-
-;;;then actually define the base presentations :
-(define-base-mewa-presentations
- boolean
- string
- number
- integer
- currency)
-
-(defslot-presentation clsql-wall-time-slot-presentation (mewa-relation-slot-presentation)
- ((input-id :accessor input-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
- (trigger-id :accessor trigger-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
- (default-to-now-p :accessor default-to-now-p :initarg :default-to-now-p :initform nil))
- (:type-name clsql-sys:wall-time))
-
-(defmethod lol::presentation-slot-value ((slot clsql-wall-time-slot-presentation) instance)
- (let ((date (call-next-method)))
- (when date (multiple-value-bind (y m d) (clsql:time-ymd date)
- (format nil "~a/~a/~a" m d y)))))
-
-(defmethod (setf lol::presentation-slot-value) ((value string) (slot clsql-wall-time-slot-presentation) instance)
- (let ((new-time (clsql:parse-date-time (remove #\Space value)))
- (old-time (when (slot-boundp instance (slot-name slot))
- (slot-value instance (slot-name slot)))))
- (unless (or (eql old-time new-time)
- (when (and new-time old-time)
- (equal :equal (clsql:time-compare new-time old-time))))
- (setf (presentation-slot-value slot instance) new-time))))
-
-(defmethod label :around ((slot clsql-wall-time-slot-presentation))
- (concatenate 'string (call-next-method) " (m/d/y)"))
-
-(defmethod lol::present-slot ((slot clsql-wall-time-slot-presentation) instance)
- (let ((date (lol::presentation-slot-value slot instance)))
- ;; Default values
- (when (and (not date) (default-to-now-p slot))
- (setf (lol::presentation-slot-value slot instance) (clsql:get-time)))
- ;;simple viewer
- (if (and date (not (editablep slot)))
- (<:as-html date))
- ;; editor
- (when (editablep slot)
- (<ucw:input :accessor (lol::presentation-slot-value slot instance) :id (input-id slot) :style "display:inline")
- (<:button :id (trigger-id slot) (<:as-html "[...]"))
- (<:script :type "text/javascript"
- (<:as-is (format nil "
-
-Calendar.setup({
- inputField : \"~a\",
- button : \"~a\",
- ifFormat : \"%m/%d/%Y\" });" (input-id slot) (trigger-id slot)))))))
-
-(defslot-presentation mewa-relation-slot-presentation (mewa-slot-presentation slot-presentation)
- ((foreign-instance :accessor foreign-instance)
- (linkedp :accessor linkedp :initarg :linkedp :initform t)
- (creator :accessor creator :initarg :creator :initform :editor)
- (new-instance :accessor new-instance :initform nil))
- (:type-name relation))
-
-(defaction search-records ((slot mewa-relation-slot-presentation) instance)
- (multiple-value-bindf (finstance foreign-slot-name)
- (meta-model:explode-foreign-key instance (slot-name slot))
- (let ((new-instance (new-instance self)))
- (unless new-instance
- (setf (new-instance self)
- (call-component
- (ucw::parent slot)
- (make-instance (or (cadr (mewa:find-attribute finstance :presentation-search))
- 'mewa::mewa-presentation-search)
- :search-presentation
- (mewa:make-presentation finstance
- :type :search-presentation)
- :list-presentation
- (mewa:make-presentation finstance
- :type :listing)))))
- (sync-foreign-instance slot new-instance))))
-
-(defmethod sync-foreign-instance ((slot mewa-relation-slot-presentation) foreign-instance)
- (let ((instance (instance (ucw::parent slot))))
- (multiple-value-bind (foo f-slot-name)
- (meta-model:explode-foreign-key instance (slot-name slot))
- (setf (slot-value instance (slot-name slot)) (slot-value foreign-instance f-slot-name))
- (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p slot)))))
-
-
-(defaction create-record-on-foreign-key ((slot mewa-relation-slot-presentation) instance)
- (multiple-value-bindf (finstance foreign-slot-name)
- (meta-model:explode-foreign-key instance (slot-name slot))
- (let ((new-instance
- (call-component
- (ucw::parent slot)
- (mewa:make-presentation finstance :type (creator self)))))
-
- ;;;; TODO: this next bit is due to a bad design decision.
- ;;;; Components should always have (ok) return self, but somewhere
- ;;;; i've made in return (instance self) sometimes, and this
- ;;;; bahaviour is totatlly fucked.
-
- (when (typep new-instance 'mewa::mewa)
- (setf new-instance (instance new-instance)))
-
- ;;;; sorry about that, and now back t our regular program.
-
- (meta-model:sync-instance new-instance)
- (setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name))
- (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p self)))))
-
-
-(defmethod present-relation ((slot mewa-relation-slot-presentation) instance)
- ;;;;(<:as-html (slot-name slot) "=> " (foreign-instance slot) " from " instance )
- (let* ((i (foreign-instance slot))
- (pres (mewa::make-presentation
- i
- :type :one-line
- :initargs (list
- :global-properties
- (list :editablep nil :linkedp nil)))))
- (when (and (ucw::parent slot) (slot-boundp slot 'ucw::place))
- (setf (component.place pres) (component.place (ucw::parent slot))))
- (when i (<ucw:render-component :component pres))))
-
-(defmethod present-slot ((slot mewa-relation-slot-presentation) instance)
- (present-relation slot instance))
-
-(defslot-presentation foreign-key-slot-presentation (mewa-relation-slot-presentation)
- ()
- (:type-name foreign-key)
- (:default-initargs))
-
-(defaction view-instance ((self component) instance &rest initargs)
- (call-component (ucw::parent self) (apply #'mewa:make-presentation instance initargs))
- ;; the viewed instance could have been changed/deleted, so we sync this instance
- (meta-model:sync-instance (instance (ucw::parent self))))
-
-(defmethod present-slot :around ((slot foreign-key-slot-presentation) instance)
- (setf (foreign-instance slot)
- (when (lol::presentation-slot-value slot instance)
- (meta-model:explode-foreign-key instance (slot-name slot) :nilp t)))
- (flet ((render () (when (foreign-instance slot)(call-next-method))))
- (if (slot-boundp slot 'ucw::place)
- (cond
- ((editablep slot)
- (render)
- (<ucw:submit :action (search-records slot instance) :value "Search" :style "display:inline")
- (<ucw:submit :action (create-record-on-foreign-key slot instance) :value "Add New" :style "display:inline"))
- ((linkedp slot)
- (<ucw:a :action (view-instance slot (foreign-instance slot))
- (render)))
- (t
- (render)))
- ;; presentation is used only for rendering
- (render))))
-
-
-(defmethod find-foreign-instances ((slot foreign-key-slot-presentation))
- (clsql:select (class-name (class-of (meta-model:explode-foreign-key (instance slot) (slot-name slot))))
- :order-by (car (list-keys (instance slot)))))
-
-
-
-;;;; HAS MANY
-(defslot-presentation has-many-slot-presentation (mewa-relation-slot-presentation)
- ((add-new-label :accessor add-new-label :initarg :add-new-label :initform "Add New"))
- (:type-name has-many))
-
-(defaction add-to-has-many ((slot has-many-slot-presentation) instance)
- ;; if the instance is not stored we must make sure to mark it stored now!
- (unless (meta-model::persistentp instance)
- (setf (mewa::modifiedp (ucw::parent self)) t))
- ;; sync up the instance
- ;;(mewa:ensure-instance-sync (parent slot))
- (meta-model:sync-instance (instance (ucw::parent slot)))
-
- (multiple-value-bindf (class home foreign)
- (meta-model:explode-has-many instance (slot-name slot))
- (let ((new (make-instance class)))
- (setf (slot-value new foreign) (slot-value instance home))
- (meta-model:sync-instance new :fill-gaps-only-p (fill-gaps-only-p self))
- (call-component (ucw::parent slot) (mewa:make-presentation new :type (creator slot)))
- (meta-model:sync-instance instance))))
-
-(defmethod present-slot ((slot has-many-slot-presentation) instance)
- (when (slot-boundp slot 'ucw::place)
- (<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label slot)))
- (let* ((i (get-foreign-instances slot instance))
- (presentation (and i (make-presentation (car i) :type :one-line))))
- (when i
- (flet ((linker (i string)
- (<ucw:a
- :action (view-instance slot i
- :initargs
- `(:global-properties ,
- (list
- :linkedp t
- :editablep nil)))
- (<:as-html string))))
- (<:table :cellpadding 10
- (<:tr
- (<:th) ;empty col for (view) link
- (dolist (s (slots presentation))
- (<:th (<:as-html (label s)))))
- (dolist (s i)
- (let ((s s))
- (setf (foreign-instance slot) s)
- (when (slot-boundp slot 'ucw::place)
- (<:tr
- (<:td (linker s " (view) "))
- (dolist (p (slots (make-presentation s :type :one-line
- :initargs
- '(:global-properties
- (:editablep nil)))))
- (<:td
-
- (present-slot p s))))))))))))
-
-
-(defmethod get-foreign-instances ((slot has-many-slot-presentation) instance)
- (sort (slot-value instance (slot-name slot)) #'<
- :key #'(lambda (x) (funcall (car (list-keys x)) x))))
-
-(defmethod lol::presentation-slot-value ((slot has-many-slot-presentation) instance)
- (get-foreign-instances slot instance))
-
-(defslot-presentation has-very-many-slot-presentation (has-many-slot-presentation)
- ((number-to-display :accessor number-to-display :initarg :number-to-display :initform 10)
- (current :accessor current :initform 0)
- (len :accessor len )
- (instances :accessor instances))
- (:type-name has-very-many))
-
-(defmethod list-next ((slot has-very-many-slot-presentation))
- (setf (current slot) (incf (current slot) (number-to-display slot)))
- (when (< (len slot) (current slot))
- (setf (current slot) (- (number-to-display slot) (len slot)))))
-
-(defmethod list-prev ((slot has-very-many-slot-presentation))
- (setf (current slot) (decf (current slot) (number-to-display slot)))
- (when (> 0 (current slot))
- ;;what to do here is open to debate
- (setf (current slot) (- (len slot)(number-to-display slot) ))))
-
-
-(defmethod present-slot ((slot has-very-many-slot-presentation) instance)
- ;;(<:as-html "isance: " instance)
- (if (slot-boundp slot 'ucw::place)
- (progn
- (<ucw:a :action (list-prev slot) (<:as-html "<<"))
- (let ((self (ucw::parent slot)))
- (<ucw:a :action (call-component self (mewa:make-presentation (car (slot-value instance (slot-name slot))) :type :listing :initargs (list :instances (instances slot))))
- (<:as-html (label slot) (format nil " ~a-~a " (current slot) (+ (current slot) (number-to-display slot))))))
- (<ucw:a :action (list-next slot) (<:as-html ">>"))
- (call-next-method)
- (<:as-html "total :" (len slot)))
- (call-next-method)))
-
-(defmethod get-foreign-instances :around ((slot has-very-many-slot-presentation) instance)
- (let ((f (call-next-method)))
- (setf (len slot) (length f))
- (setf (instances slot) f)
- (loop for cons on (nthcdr (current slot) f)
- for i from 0 upto (number-to-display slot)
- collect (car cons))))
-
-
-;;;; * Has-a
-(defslot-presentation has-a-slot-presentation (mewa-relation-slot-presentation)
- ((allow-nil-p :accessor allow-nil-p :initarg :allow-nil-p :initform t)
- (attributes :accessor attributes :initarg :attributes :initform nil))
- (:type-name has-a))
-
-(defmethod find-foreign-slot-value ((slot has-a-slot-presentation) (object t))
- (multiple-value-bind (c s)
- (meta-model:explode-foreign-key (instance (ucw::parent slot)) (slot-name slot))
- (slot-value object s)))
-
-(defmethod get-foreign-instances ((slot mewa-relation-slot-presentation) instance)
- (clsql:select (class-name (class-of
- (meta-model:explode-foreign-key instance (slot-name slot))))
- :flatp t))
-
-(defmethod present-slot ((slot has-a-slot-presentation) instance)
-; (<:as-html (lol::presentation-slot-value slot instance))
- (if (editablep slot)
- (progn (<ucw:select :accessor (lol::presentation-slot-value slot instance) :test #'equalp
- (when (allow-nil-p slot)
- (<ucw:option :value nil (<:as-html "none")))
- (dolist (option (get-foreign-instances slot instance))
- (<ucw:option :value (find-foreign-slot-value slot option)
- (lol::present
- (lol::make-presentation option
- :type :as-string
- :initargs
- `(:attributes ,(attributes slot)))
- ))))
- (when (creatablep slot)
- (<ucw:submit :action (create-record-on-foreign-key slot instance) :value "Add New" :style "display:inline")))
- (if (lol::presentation-slot-value slot instance)
- (progn
- (lol::present
- (lol:make-presentation (meta-model:explode-foreign-key instance (slot-name slot))
- :type :one-line
- :initargs
- `(:attributes ,(attributes slot)))
- ))
- (<:as-html "--"))))
-
-(defslot-presentation many-to-many-slot-presentation (mewa-relation-slot-presentation)
- ((list-view :accessor list-view :initarg :list-view :initform :one-line)
- (action-view :accessor action-view :initarg :action-view :initform :viewer)
- (create-view :initform :creator)
- (select-view :initform :as-string :accessor select-view)
- (can-add-new-p :initarg :can-add-new-p :accessor can-add-new-p :initform t)
- (can-add-existing-p :initarg :can-add-existing-p :accessor can-add-existing-p :initform t))
- (:type-name many-to-many)
- (:default-initargs :label "many to many"))
-
-(defun %delete-item (item)
- (clsql:with-default-database (clsql:*default-database*)
- (ignore-errors
- (clsql:delete-instance-records item))))
-
-(defaction delete-item ((self component) instance)
- (multiple-value-bind (res err) (%delete-item instance)
- (if (not err)
- (call 'info-message :message "Removed Instance")
- (call 'info-message :message (format nil "Could not remove item. Try removing associated items first. ~A" instance)))))
-
-(defaction delete-relationship ((slot many-to-many-slot-presentation) rel instance)
- (delete-item (ucw::parent self) rel)
- (sync-instance instance)
- (answer-component (ucw::parent self) t))
-
-
-(defun find-many-to-many-join-class (slot instance)
- (let* ((imd (getf (meta-model::find-slot-metadata instance (slot-name slot))
- :db-info))
- (jc (make-instance (getf imd :join-class)))
- (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
- :db-info)))
- (getf jcmd :join-class)))
-
-(defmethod find-all-instances ((slot many-to-many-slot-presentation) instance)
- (clsql:select (find-many-to-many-join-class slot instance) :flatp t))
-
-(defmethod present-slot ((slot many-to-many-slot-presentation) instance)
- (let ((instances (slot-value instance (slot-name slot)))
- new-instance)
- (<:ul
- (when (can-add-new-p slot)
- (<:li
- (<ucw:submit :action (add-to-many-to-many slot instance)
-
- :value "Add New")))
- (when (can-add-existing-p slot )
- (<:li (<ucw:submit :action (add-to-many-to-many slot instance new-instance)
- :value "Add:")
- (<ucw:select :accessor new-instance
- (arnesi:dolist* (i (find-all-instances slot instance))
- (<ucw:option
- :value i
- (lol:present-view (i (select-view slot) slot)))))))
- (dolist* (i instances)
- (<:li
- (<ucw:a :action (call-view ((car i) (action-view slot) (ucw::parent slot)))
- (<:as-html "(view) "))
- (<ucw:a :action (delete-relationship slot (second i) instance)
- (<:as-html "(remove) "))
- (present-view ((car i) (list-view slot) (ucw::parent slot))))))))
-
-
-(defaction add-to-many-to-many ((slot many-to-many-slot-presentation) instance &optional foreign-instance)
- ;;;; First things first, we sync.
- (sync-instance instance)
- (let* (new
- (imd (getf (meta-model::find-slot-metadata instance (slot-name slot))
- :db-info))
- (jc (make-instance (getf imd :join-class)))
- (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
- :db-info))
- (fc (make-instance (getf jcmd :join-class)))
- (c (if
- foreign-instance
- foreign-instance
- (call-view (fc :creator (ucw::parent slot))))))
- (when c
- (sync-instance c)
-; (error "~A ~A ~A" (getf imd :foreign-key) (getf jcmd :foreign-key) (getf imd :home-key))
- (setf (slot-value jc (getf imd :foreign-key))
- (slot-value instance (getf imd :home-key)))
- (setf (slot-value jc (getf jcmd :home-key))
- (slot-value c (getf jcmd :foreign-key)))
- (sync-instance jc)
-
- (sync-instance instance)
- c)))
+++ /dev/null
-(in-package :lol)
-
-(defclass form-element (widget-component)
- ((client-value :accessor client-value :initform ""
- :initarg :client-value
- :documentation "Whetever the client's browse sent for this form element."
- :backtrack t)
- (lisp-value :accessor lisp-value :initform +uninitialized+
- :initarg :lisp-value
- :documentation "The current lisp object in this form element."
- :backtrack t))
- (:metaclass standard-component-class)
- (:documentation "A single value in a form.
-
-A form-element is, simply put, a wrapper for a value in an html
-form."))
-
-;;;; Expiry date picker
-
-(defslot-presentation date-slot-presentation (clsql-wall-time-slot-presentation)
- ((date-field :component (my-date-field :year-min 2005 :year-max 2015)
- :accessor date-field))
- (:type-name date))
-
-(defmethod update-value ((slot date-slot-presentation))
- (multiple-value-bind (year month day)
- (time-ymd (presentation-slot-value slot (instance (ucw::parent slot))))
- (multiple-value-bind (new-year new-month new-day)
- (time-ymd)
- (if (remove nil (map 'list #'(lambda (old new)
- (unless (equal (car old) (car new))
- t))
- (list year month day)
- (list new-year new-month new-day)))
- (setf (presentation-slot-value slot (instance (ucw::parent slot)))
- (make-time t))))))
-
-(defmethod present-slot ((slot date-slot-presentation) instance)
- (let ((date (slot-value instance (slot-name slot))))
- ;; Default values
- (when (and (not date) (default-to-now-p slot))
- (setf date (clsql:get-time)
- (presentation-slot-value slot instance) date))
- ;;simple viewer
- (if (and date (not (editablep slot)))
- (<:as-html date))
- ;; editor
- (when (editablep slot)
- (with-slots ((m month) (y year))
- (date-field slot)
-
- (multiple-value-bind (year month) (time-ymd date)
- (setf (lisp-value m) month
- (lisp-value y) year)
- (<ucw:render-component :component (date-field slot)))))))
-
-
-
-
-(defcomponent %integer-range-field (integer-range-field)
- ())
-
-(defmethod (setf lisp-value) :after (value (self %integer-range-field))
- ())
-(defclass date-field (form-element)
- ((day :component (integer-range-field :min-value 1 :max-value 31))
- (month :component (integer-range-field :min-value 1 :max-value 12))
- (year :component integer-range-field))
- (:metaclass standard-component-class))
-
-(defmethod shared-initialize :after ((field date-field) slot-names
- &key (year-min 1960) (year-max 2010))
- (declare (ignore slot-names))
- (setf (min-value (slot-value field 'year)) year-min
- (max-value (slot-value field 'year)) year-max
- (max-value (slot-value field 'day)) 31
- (max-value (slot-value field 'month)) 12))
-
-(defmethod read-client-value ((date date-field))
- (with-slots (year month day)
- date
- (read-client-value year)
- (read-client-value month)
- (read-client-value day)
- (setf (lisp-value date) (encode-universal-time 0 0 0
- (lisp-value day)
- (lisp-value month)
- (lisp-value year)))))
-
-
-(defclass %date-field (date-field)
- ((day :component (%integer-range-field :min-value 1 :max-value 31))
- (month :component (%integer-range-field :min-value 1 :max-value 12))
- (year :component (%integer-range-field :min-value 2006 :max-value 2015) ))
- (:metaclass standard-component-class))
-
-(defmethod shared-initialize :after ((field %date-field) slot-names
- &key (year-min 1960) (year-max 2010))
- (declare (ignore slot-names year-min year-max))
- (mapcar #'(lambda (x) (setf (slot-value (slot-value field x) 'ucw::parent) field))
- '(year month day)))
-
-(defclass my-date-field (%date-field)
- ()
- (:metaclass standard-component-class))
-
-(defmethod present ((date my-date-field))
- (with-slots (year month)
- date
- (<ucw:render-component :component month)
- "/"
- (<ucw:render-component :component year)))
-
-
-
-(defconstant +uninitialized+ '+uninitialized+
- "The value used in UCW form elements to specify that there is no value.
-
-This obviously implies that you can't have a form element whose
-real value is +uninitialized+, since +uninitialized+ is a ucw
-internal symbol this shouldn't be a problem.")
-
-
-
-(defgeneric read-client-value (element)
- (:method ((element form-element))
- (setf (lisp-value element) (client-value element))))
-
-(defclass form-component (widget-component)
- ()
- (:metaclass standard-component-class))
-
-;; remeber that actions are just methods
-(defgeneric/cc submit (form))
-
-(defaction submit :before ((f form-component))
- (iterate
- (with form-element-class = (find-class 'form-element))
- (for slot in (mopp:class-slots (class-of f)))
- (for slot-name = (mopp:slot-definition-name slot))
- (when (and (slot-boundp f slot-name)
- (subtypep (class-of (slot-value f slot-name)) form-element-class))
- (read-client-value (slot-value f slot-name)))))
-
-(defaction submit ((f form-component)) t)
-
-
-(defclass select-field (form-element)
- ((options :accessor options :initform '() :initarg :options)
- (key :accessor key :initform #'identity :initarg :key)
- (test :accessor test :initform #'eql :initarg :test)
- (option-map :accessor option-map :initform (make-array 10 :adjustable t :fill-pointer 0))
- (option-writer :accessor option-writer :initform #'princ-to-string))
- (:metaclass standard-component-class))
-
-(defmethod render-option ((select select-field) (object t))
- (<:as-html (funcall (option-writer select) object)))
-
-(defmethod render ( (select select-field))
- (setf (fill-pointer (option-map select)) 0)
- (<:select :name (make-new-callback (context.current-frame *context*)
- (lambda (v) (setf (client-value select) v)))
- (iterate
- (for o in (options select))
- (for index upfrom 0)
- (vector-push-extend o (option-map select))
- (<:option :value index
- :selected (funcall (test select)
- (funcall (key select) o)
- (funcall (key select) (lisp-value select)))
- (render-option res select o)))))
-
-(defmethod read-client-value ((select select-field))
- (with-slots (lisp-value option-map client-value)
- select
- (setf lisp-value (aref option-map (parse-integer client-value)))))
-
-;;;; Numbers from text inputs
-
-(defclass number-field (form-element)
- ((min-value :accessor min-value :initform nil :initarg :min-value)
- (max-value :accessor max-value :initform nil :initarg :max-value)
- (size :accessor size :initarg :size :initform 0)
- (maxlength :accessor maxlength :initarg :maxlength :initform 20))
- (:metaclass standard-component-class))
-
-(defmethod validate-form-element ((number number-field))
- (with-slots (min-value max-value lisp-value)
- number
- (if (eql +uninitialized+ lisp-value)
- nil
- (if (numberp lisp-value)
- (cond
- ((and min-value max-value)
- (< min-value lisp-value max-value))
- (min-value (< min-value lisp-value))
- (max-value (< lisp-value max-value))
- (t lisp-value))
- nil))))
-
-(defmethod read-client-value :around ((number number-field))
- (unless (or (null (client-value number))
- (string= "" (client-value number)))
- (ignore-errors ; returns NIL in case of SIMPLE-PARSE-ERROR
- (call-next-method))))
-
-(defmethod render ( (n number-field))
- (<ucw:input :type "text" :accessor (client-value n)
- :size (size n)
- :value (if (eql +uninitialized+ (lisp-value n))
- ""
- (lisp-value n))
- :maxlength (maxlength n)))
-
-(defclass decimal-field (number-field)
- ((precision :accessor precision :initarg :precision :initform nil
- :documentation "Number of significant digits."))
- (:metaclass standard-component-class))
-
-(defmethod read-client-value ((decimal number-field))
- (setf (lisp-value decimal) (parse-float (client-value decimal))))
-
-(defclass integer-field (number-field)
- ()
- (:metaclass standard-component-class))
-
-(defmethod read-client-value ((integer integer-field))
- (setf (lisp-value integer) (parse-integer (client-value integer))))
-
-(defclass integer-range-field (integer-field)
- ()
- (:metaclass standard-component-class)
- (:default-initargs :min-value 1 :max-value 5))
-
-(defmethod shared-initialize :after ((field integer-range-field) slot-names
- &rest initargs)
- (declare (ignore slot-names initargs))
- (setf (lisp-value field) (min-value field)))
-
-(defmethod render ( (range integer-range-field))
- (<:select :name (ucw::make-new-callback
- (lambda (v) (setf (client-value range) v)))
- (iterate
- (for value from (min-value range) to (max-value range))
- (<:option :value value :selected (= value (lisp-value range))
- (<:as-html value)))))
(defmethod list-slots (thing)
(list 'identity))
-
-;;;; TODO : this doesn't work
-
-(defaction call-display-with-context ((from component) object context &rest properties)
- (call-component self (make-instance 'standard-display-component
- :context context
- :object object
- :args (if (cdr properties)
- properties
- (car properties)))))
-
-(defmacro call-display (component object &rest properties)
- `(let ()
- (call-display-with-context ,component ,object nil ,@properties)))
-
-(defcomponent standard-display-component ()
- ((context :accessor context :initarg :context)
- (object :accessor object-of :initarg :object)
- (args :accessor args :initarg :args)))
-
-(defmethod render ((self standard-display-component))
-
- (apply #'display self (object-of self) (args self)))
-
-
;;;; * Object displays.
(defdisplay (desc (list list))
(with-active-layers (list-display-layer)
-
(<:ul
(dolist* (item list)
(<:li (apply #'display* item (list-item desc)))))))
(defdisplay
:in-layer editor
((attribute standard-attribute) object)
- "Legacy editor using UCW presentations"
-
- (warn "USING LEGACY EDITOR FOR ~A" (slot-name attribute)))
+ (call-next-method))
(define-layered-method display-using-description
((attribute standard-attribute) object component)
+++ /dev/null
-;;;; -*- 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)
- (if (editablep slot)
- (let ((callback (ucw::make-new-callback
- (lambda (val)
-
- (if (listp val)
- (setf (presentation-slot-value slot instance) t)
- (setf (presentation-slot-value slot instance) nil))))))
- (<:input :type "hidden" :name callback :value "DEFAULT")
- (<:input :type "checkbox"
- :name callback
- :checked (slot-value instance (slot-name slot))))
- (<:as-html
- (if (presentation-slot-value slot instance)
- "YES"
- "NO"))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; 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)))
-
HCoop / clinton / lisp-on-lines.git / commitdiff