1 (declaim (optimize (speed 2) (space 3) (safety 0)))
3 (in-package :lisp-on-lines
)
5 (defparameter *default-type
* :ucw
)
7 ;;;; I think these are unused now
8 (defmethod perform-set-attributes ((occurence-name t
) definitions
)
9 (dolist (def definitions
)
10 (funcall #'set-attribute occurence-name
(first def
) (rest def
))))
12 (defmethod perform-set-attribute-properties ((occurence-name t
) definitions
)
13 (dolist (def definitions
)
14 (funcall #'set-attribute-properties occurence-name
(car def
) (cdr def
))))
18 (defun plist-nunion (new-props plist
)
19 "Destructive Merge of plists. PLIST is modified and returned.
20 NEW-PROPS is merged into PLIST such that any properties
21 in both PLIST and NEW-PROPS get the value in NEW-PROPS.
22 The other properties in PLIST are left untouched."
23 (loop for cons on new-props by
#'cddr
24 do
(setf (getf plist
(first cons
)) (second cons
))
25 finally
(return plist
)))
27 (defun plist-union (new-props plist
)
28 "Non-destructive version of plist-nunion"
29 (plist-nunion new-props
(copy-list plist
)))
34 (defvar *occurence-map
* (make-hash-table)
35 "Presentations are created by associating an 'occurence'
36 with an instance of a class. This is usually keyed off class-name,
37 although an arbitrary occurence can be used with an arbitrary class.")
41 ((attribute-map :accessor attribute-map
:initform
(make-hash-table)))
43 "an occurence holds the attributes like a class holds slot-definitions.
44 Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."))
46 (defun find-or-create-occurence (name)
47 "Returns the occurence associated with this name."
48 (let ((occurence (gethash name
*occurence-map
*)))
51 (let ((new-occurence (make-instance 'standard-occurence
)))
52 (setf (gethash name
*occurence-map
*) new-occurence
)
55 (defun clear-occurence (occurence)
56 "removes all attributes from the occurence"
57 (setf (attribute-map occurence
) (make-hash-table)))
59 (defgeneric find-occurence
(name)
60 (:method
((name symbol
))
61 (find-or-create-occurence name
))
63 (find-or-create-occurence (class-name (class-of instance
)))))
70 ((name :layered-accessor attribute.name
:initarg
:name
:initform
"attribute")
71 (type :layered-accessor attribute.type
:initarg
:type
:initform t
:type symbol
)
72 (plist :layered-accessor attribute.plist
:initarg
:plist
:initform nil
))
73 (:documentation
"Attributes are used to display a part of a thing, such as a slot of an object, a text label, the car of a list, etc."))
76 (defmethod print-object ((self standard-attribute
) stream
)
77 (print-unreadable-object (self stream
:type t
)
78 (with-slots (name type
) self
79 (format stream
"~A ~A" name type
))))
82 presentation-attribute
(standard-attribute)
84 (:documentation
"Presentation Attributes are used to display objects
85 using the attributes defined in an occurence. Presentation Attributes are always named using keywords."))
87 (defun clear-attributes (name)
88 "removes all attributes from an occurance"
89 (clear-occurence (find-occurence name
)))
91 (defmethod find-attribute-class-for-name (name)
92 "presentation attributes are named using keywords"
94 'presentation-attribute
97 (defmethod ensure-attribute ((occurence standard-occurence
) name type plist
)
98 "Creates an attribute in the given occurence"
99 (setf (gethash name
(attribute-map occurence
))
100 (make-instance (find-attribute-class-for-name name
)
101 :name name
:type type
:plist plist
)))
103 (defmethod find-attribute ((occurence standard-occurence
) name
)
104 (gethash name
(attribute-map occurence
)))
106 (defmethod find-all-attributes ((occurence standard-occurence
))
107 (loop for att being the hash-values of
(attribute-map occurence
)
110 (defmethod ensure-attribute (occurence-name name type plist
)
112 (find-occurence occurence-name
)
117 ;;;; The following functions make up the public interface to the
118 ;;;; MEWA Attribute Occurence system.
120 (defmethod find-all-attributes (occurence-name)
121 (find-all-attributes (find-occurence occurence-name
)))
123 (defmethod find-attribute (occurence-name attribute-name
)
124 "Returns the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name"
125 (find-attribute (find-occurence occurence-name
) attribute-name
))
127 (defmethod (setf find-attribute
) ((def list
) occurence-name attribute-name
)
128 (ensure-attribute occurence-name attribute-name
(first def
) (rest def
)))
130 (defmethod set-attribute (occurence-name attribute-name definition
&key
(inherit t
))
131 (let ((att (find-attribute occurence-name attribute-name
)))
132 (setf (find-attribute occurence-name attribute-name
)
133 (if (and att inherit
)
134 (cons (car definition
)
135 (plist-union (cdr definition
)
136 (attribute.plist att
)))
139 (defmethod set-attribute-properties ((occurence-name t
) attribute properties
)
140 (let ((a (find-attribute occurence-name attribute
)))
142 (setf (attribute.plist a
) (plist-nunion properties
(attribute.plist a
)))
143 (error "Attribute ~A does not exist" attribute
))))
145 (defmethod perform-define-attributes ((occurence-name t
) attributes
)
146 (loop for attribute in attributes
147 do
(destructuring-bind (name type
&rest args
)
150 ;;use the existing (default) type
151 (set-attribute-properties occurence-name name args
))
153 ;;set the type as well
154 (set-attribute occurence-name name
(cons type args
)))))))
156 (defmacro define-attributes
(occurence-names &body attribute-definitions
)
158 ,@(loop for occurence-name in occurence-names
159 collect
`(perform-define-attributes (quote ,occurence-name
) (quote ,attribute-definitions
)))))
162 (defmethod setter (attribute)
163 (let ((setter (getf (attribute.plist attribute
) :setter
))
164 (slot-name (getf (attribute.plist attribute
) :slot-name
)))
168 #'(lambda (value object
)
169 (setf (slot-value object slot-name
) value
)))
171 #'(lambda (value object
)
172 (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute
))))))
174 (defmethod getter (attribute)
175 (let ((getter (getf (attribute.plist attribute
) :getter
))
176 (slot-name (getf (attribute.plist attribute
) :slot-name
)))
181 (when (slot-boundp object slot-name
)
182 (slot-value object slot-name
)))))))
184 (defgeneric attribute-value
(instance attribute
)
185 (:method
(instance (attribute standard-attribute
))
186 (funcall (getter attribute
) instance
)))
188 (defgeneric (setf attribute-value
) (value instance attribute
)
189 (:method
(value instance
(attribute standard-attribute
))
190 (funcall (setter attribute
) value instance
)))
193 ;;;; ** Default Attributes
196 ;;;; The default mewa class contains the types use as defaults.
197 ;;;; maps meta-model slot-types to slot-presentation
199 (defvar *default-attributes-class-name
* 'default
)
201 (defmacro with-default-attributes
((occurence-name) &body body
)
202 `(let ((*default-attributes-class-name
* ',occurence-name
))
205 (define-attributes (default)
206 (boolean mewa-boolean
)
208 (number mewa-currency
)
209 (integer mewa-integer
)
210 (currency mewa-currency
)
211 (clsql:generalized-boolean mewa-boolean
)
212 (foreign-key foreign-key
)
213 (:viewer mewa-viewer
)
214 (:editor mewa-editor
)
215 (:creator mewa-creator
)
216 (:as-string mewa-one-line-presentation
)
217 (:one-line mewa-one-line-presentation
)
218 (:listing mewa-list-presentation
:global-properties
(:editablep nil
) :editablep t
)
219 (:search-model mewa-object-presentation
))
221 (defun find-presentation-attributes (occurence-name)
222 (loop for att in
(find-all-attributes occurence-name
)
223 when
(typep att
'presentation-attribute
)
226 (defun attribute-to-definition (attribute)
227 (nconc (list (attribute.name attribute
)
228 (attribute.type attribute
))
229 (attribute.plist attribute
)))
231 (defun find-default-presentation-attribute-definitions ()
232 (if (eql *default-attributes-class-name
* 'default
)
233 (mapcar #'attribute-to-definition
(find-presentation-attributes 'default
))
234 (remove-duplicates (mapcar #'attribute-to-definition
236 (find-presentation-attributes 'default
)
237 (find-presentation-attributes
238 *default-attributes-class-name
*))))))
239 (defun gen-ptype (type)
240 (let* ((type (if (consp type
) (car type
) type
))
241 (possible-default (find-attribute *default-attributes-class-name
* type
))
242 (real-default (find-attribute 'default type
)))
245 (attribute.type possible-default
))
247 (attribute.type real-default
))
250 (defun gen-presentation-slots (instance)
251 (mapcar #'(lambda (x) (gen-pslot (cadr x
)
254 (meta-model:list-slot-types instance
)))
257 (defun gen-pslot (type label slot-name
)
258 (copy-list `(,(gen-ptype type
)
260 :slot-name
,slot-name
)))
262 (defmethod find-default-attributes ((model t
))
263 "return the default attributes for a given model using the meta-model's meta-data"
264 (append (mapcar #'(lambda (s)
267 (if (meta-model:foreign-key-p model
(car s
))
270 (string (car s
)) (car s
))))
271 (meta-model:list-slot-types model
))
272 (mapcar #'(lambda (s)
273 (cons s
(append (gen-pslot 'has-many
(string s
) s
)
278 (meta-model:list-has-many model
))
279 (find-default-presentation-attribute-definitions)))
281 (defmethod set-default-attributes ((model t
))
282 "Set the default attributes for MODEL"
283 (clear-attributes model
)
284 (mapcar #'(lambda (x)
285 (setf (find-attribute model
(car x
)) (cdr x
)))
286 (find-default-attributes model
)))
289 (defcomponent mewa
()
290 ((instance :accessor instance
:initarg
:instance
)
296 :accessor attributes-getter
297 :initform
#'get-attributes
298 :initarg
:attributes-getter
)
300 :accessor attribute-slot-map
303 :initarg
:global-properties
304 :accessor global-properties
310 (use-instance-class-p
311 :initarg
:use-instance-class-p
312 :accessor use-instance-class-p
314 (initializedp :initform nil
)
315 (modifiedp :accessor modifiedp
:initform nil
:initarg
:modifiedp
)
316 (modifications :accessor modifications
:initform nil
)))
319 (defmethod attributes :around
((self mewa
))
320 (let ((a (call-next-method)))
321 (or a
(funcall (attributes-getter self
) self
))))
323 (defgeneric get-attributes
(mewa))
325 (defmethod get-attributes ((self mewa
))
327 (append (meta-model:list-slots
(instance self
))
328 (meta-model:list-has-many
(instance self
)))
331 (defmethod find-instance-classes ((self mewa
))
333 (it.bese.arnesi.mopp
:compute-class-precedence-list
(class-of (instance self
)))))
335 (defun make-attribute (&rest props
&key type
&allow-other-keys
)
337 (cons (gensym) (cons type props
)))
339 (defun make-presentation-for-attribute-list-item
340 (occurence att-name plist parent-presentation
&optional type
)
341 (declare (type list plist
) (type symbol att-name
))
342 "This is a ucw specific function that will eventually be factored elsewhere."
343 (let* ((attribute (find-attribute occurence att-name
))
344 (type (when attribute
(or type
(attribute.type attribute
))))
346 (or (gethash (if (consp type
)
349 *presentation-slot-type-mapping
*)
350 (error "Can't find slot type for ~A in ~A from ~A" att-name occurence parent-presentation
))))
352 (cons (attribute.name attribute
) (apply #'make-instance
354 (append (plist-nunion
357 (global-properties parent-presentation
)
358 (attribute.plist attribute
)))
359 (list :size
30 :parent parent-presentation
))))))
361 (defmethod find-applicable-attributes-using-attribute-list (occurence attribute-list
)
362 "Returns a list of functions that, when called with an object presentation,
363 returns the ucw slot presentation that will be used to present this attribute
364 in that object presentation."
365 (loop for att in attribute-list
367 do
(let ((att att
)) (cond
371 (make-presentation-for-attribute-list-item occurence att nil p
))
373 ;;if the car is a keyword then this is an inline def
374 ;; drewc nov 12 2005:
375 ;; i never used this, and never told anybody about it.
377 #+ (or) ((and (listp x
) (keywordp (car x
)))
378 (let ((att (apply #'make-attribute x
)))
380 (plist-union (cddr att
) (global-properties self
)))
383 ;; if the plist has a :type
384 ((and (listp att
) (getf (cdr att
) :type
))
385 (let ((type (getf (cdr att
) :type
)))
387 (make-presentation-for-attribute-list-item
388 occurence
(first att
)
393 ;;finally if we are just overiding the props
394 ((and (listp att
) (symbolp (car att
)))
396 (make-presentation-for-attribute-list-item occurence
(first att
) (rest att
) p
))
398 finally
(return (nreverse funs
))))
401 (defun find-attribute-names (mewa)
402 (mapcar #'(lambda (x)
408 (defmethod find-applicable-attributes ((self mewa
))
409 (if (attributes self
)
410 (find-applicable-attributes-using-attribute-list (instance self
) (attributes self
))
411 (find-applicable-attributes-using-attribute-list (instance (get-attributes self
)))))
414 (defmethod find-slot-presentations ((self mewa
))
415 (mapcar #'(lambda (a) (funcall a self
))
416 (find-applicable-attributes self
)))
418 (defmethod find-attribute-slot ((self mewa
) (attribute symbol
))
419 (cdr (assoc attribute
(attribute-slot-map self
))))
421 (defmethod initialize-slots ((self mewa
))
422 (when (instance self
)
423 (when (use-instance-class-p self
)
425 (append (find-instance-classes self
)
427 (setf (attribute-slot-map self
) (find-slot-presentations self
))
428 (setf (slots self
) (mapcar #'(lambda (x)(cdr x
)) (attribute-slot-map self
)))))
431 (defmethod make-presentation ((object t
) &key
(type :viewer
) (initargs nil
))
432 ;(warn "Initargs : ~A" initargs)
433 (let* ((a (find-attribute object type
))
434 (i (apply #'make-instance
438 (plist-union initargs
(when a
439 (attribute.plist a
))))))
441 (setf (slot-value i
'instance
) object
)
443 (setf (slot-value i
'initializedp
) t
)
446 (defmethod make-presentation ((list list
) &key
(type :listing
) (initargs nil
))
453 (apply #'make-presentation
(car list
) args
)))
455 (defmethod initialize-slots-place ((place ucw
::place
) (mewa mewa
))
456 (setf (slots mewa
) (mapcar #'(lambda (x)
458 (setf (component.place x
) place
)))
461 (arnesi:defmethod
/cc call-component
:before
((from standard-component
) (to mewa
))
462 (unless (slot-value to
'initializedp
)
463 (initialize-slots to
))
464 (setf (slot-value to
'initializedp
) t
)
465 (initialize-slots-place (component.place from
) to
)
470 (defmacro call-presentation
(object &rest args
)
471 `(present-object ,object
:presentation
(make-presentation ,object
,@args
)))
474 (defcomponent about-dialog
(option-dialog)
475 ((body :initarg
:body
)))
477 (defmethod render-on ((res response
) (self about-dialog
))
479 (render-on res
(slot-value self
'body
)))
484 (defaction cancel-save-instance
((self mewa
))
486 ((meta-model::persistentp
(instance self
))
487 (meta-model::update-instance-from-records
(instance self
))
491 (defaction save-instance
((self mewa
))
492 (meta-model:sync-instance
(instance self
))
493 (setf (modifiedp self
) nil
)
496 (defmethod confirm-sync-instance ((self mewa
))
499 (defaction ensure-instance-sync
((self mewa
))
500 (when (modifiedp self
)
502 (let ((message (format nil
"Record has been modified, Do you wish to save the changes?")))
503 (case (call 'about-dialog
504 :body
(make-presentation (instance self
)
507 :options
'((:save .
"Save changes to Database")
508 (:cancel .
"Cancel all changes")))
510 (cancel-save-instance self
))
512 (save-instance self
))))
513 (save-instance self
))))
515 (defaction sync-and-answer
((self mewa
))
516 (ensure-instance-sync self
)
517 (answer (instance self
)))
519 (defaction ok
((self mewa
) &optional arg
)
520 "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
521 ;(declare (ignore arg))
522 (sync-and-answer self
))
524 (defmethod (setf presentation-slot-value
) :around
(value (slot slot-presentation
) instance
)
526 (presentation-slot-value slot instance
)
528 (new (presentation-slot-value slot instance
)))
530 (unless (equal new old
)
531 (let ((self (ucw::parent slot
)))
532 (setf (modifiedp self
) instance
533 (modifications self
) (append (list new old value slot instance
) (modifications self
)))))))
541 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
542 ;; You are granted the rights to distribute
543 ;; and use this software as governed by the terms
544 ;; of the Lisp Lesser GNU Public License
545 ;; (http://opensource.franz.com/preamble.html),
546 ;; known as the LLGPL.