The other properties in PLIST are left untouched."
(loop for cons on new-props by #'cddr
do (setf (getf plist (first cons)) (second cons))
- finally (return plist)))
+ finally (return plist))
+ plist)
(defun plist-union (new-props plist)
"Non-destructive version of plist-nunion"
(setf (attribute-map occurence) (make-hash-table)))
(defgeneric find-occurence (name)
+ (:method (thing)
+ nil)
(:method ((name symbol))
(find-or-create-occurence name))
- (:method (instance)
+ (:method ((instance standard-object))
(find-or-create-occurence (class-name (class-of instance)))))
standard-attribute ()
((name :layered-accessor attribute.name :initarg :name :initform "attribute")
(type :layered-accessor attribute.type :initarg :type :initform t :type symbol)
- (plist :layered-accessor attribute.plist :initarg :plist :initform nil))
+ (properties :layered-accessor attribute.properties :initarg :properties :initform nil))
(: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."))
+(defmacro defattribute (name supers slots &rest args)
+ (let ((type (or (second (assoc :type-name args)) name))
+ (properties (cdr (assoc :default-properties args))))
+ `(progn
+
+ (define-layered-class
+ ;;;; TODO: fix the naive way of making sure s-a is a superclass
+ ,name ,(or supers '(standard-attribute))
+ ,slots
+ #+ (or) ,@ (cdr args)
+ (:default-initargs :properties (list ,@properties)))
+ (defmethod find-attribute-class-for-type ((type (eql ',type)))
+ ',name))))
(defmethod print-object ((self standard-attribute) stream)
(print-unreadable-object (self stream :type t)
"removes all attributes from an occurance"
(clear-occurence (find-occurence name)))
+(defmethod find-attribute-class-for-type (type)
+ nil)
+
(defmethod find-attribute-class-for-name (name)
"presentation attributes are named using keywords"
(if (keywordp name)
'presentation-attribute
'standard-attribute))
-(defmethod ensure-attribute ((occurence standard-occurence) name type plist)
+(defun make-attribute (&key name type properties)
+ (let ((i (make-instance (or (find-attribute-class-for-type type)
+ (find-attribute-class-for-name name))
+ :name name :type type)))
+ (setf (attribute.properties i)
+ (plist-union properties (attribute.properties i)))
+ i))
+
+(defmethod ensure-attribute ((occurence standard-occurence) name type properties)
"Creates an attribute in the given occurence"
(setf (gethash name (attribute-map occurence))
- (make-instance (find-attribute-class-for-name name)
- :name name :type type :plist plist)))
+ (make-attribute :name name :type type :properties properties)))
(defmethod find-attribute ((occurence standard-occurence) name)
(gethash name (attribute-map occurence)))
(loop for att being the hash-values of (attribute-map occurence)
collect att))
-(defmethod ensure-attribute (occurence-name name type plist)
+(defmethod ensure-attribute (occurence-name name type properties)
(ensure-attribute
(find-occurence occurence-name)
name
type
- plist))
+ properties))
;;;; The following functions make up the public interface to the
;;;; MEWA Attribute Occurence system.
(if (and att inherit)
(cons (car definition)
(plist-union (cdr definition)
- (attribute.plist att)))
+ (attribute.properties att)))
definition))))
(defmethod set-attribute-properties ((occurence-name t) attribute properties)
(let ((a (find-attribute occurence-name attribute)))
(if a
- (setf (attribute.plist a) (plist-nunion properties (attribute.plist a)))
+ (setf (attribute.properties a) (plist-nunion properties (attribute.properties a)))
(error "Attribute ~A does not exist" attribute))))
(defmethod perform-define-attributes ((occurence-name t) attributes)
(defmethod setter (attribute)
- (let ((setter (getf (attribute.plist attribute) :setter))
- (slot-name (getf (attribute.plist attribute) :slot-name)))
+ (warn "Setting ~A in ~A" attribute *context*)
+ (let ((setter (getf (attribute.properties attribute) :setter))
+ (slot-name (getf (attribute.properties attribute) :slot-name)))
(cond (setter
setter)
(slot-name
(warn "Can't find anywere to set ~A in ~A using ~A" value object attribute))))))
(defmethod getter (attribute)
- (let ((getter (getf (attribute.plist attribute) :getter))
- (slot-name (getf (attribute.plist attribute) :slot-name)))
+ (let ((getter (getf (attribute.properties attribute) :getter))
+ (slot-name (getf (attribute.properties attribute) :slot-name)))
(cond (getter
getter)
(slot-name
(when (slot-boundp object slot-name)
(slot-value object slot-name)))))))
-(defgeneric attribute-value (instance attribute)
- (:method (instance (attribute standard-attribute))
- (funcall (getter attribute) instance)))
-(defgeneric (setf attribute-value) (value instance attribute)
- (:method (value instance (attribute standard-attribute))
- (funcall (setter attribute) value instance)))
+(define-layered-function attribute-value (instance attribute)
+ (:documentation " Like SLOT-VALUE for instances, the base method calls GETTER."))
+
+(define-layered-method attribute-value (instance (attribute standard-attribute))
+ (funcall (getter attribute) instance))
+
+(define-layered-function (setf attribute-value) (value instance attribute))
+
+(define-layered-method (setf attribute-value) (value instance (attribute standard-attribute))
+ (funcall (setter attribute) value instance))
;;;; ** Default Attributes
(defun attribute-to-definition (attribute)
(nconc (list (attribute.name attribute)
(attribute.type attribute))
- (attribute.plist attribute)))
+ (attribute.properties attribute)))
(defun find-default-presentation-attribute-definitions ()
(if (eql *default-attributes-class-name* 'default)
:label ,label
:slot-name ,slot-name)))
-(defmethod find-default-attributes ((model t))
- "return the default attributes for a given model using the meta-model's meta-data"
- (append (mapcar #'(lambda (s)
- (cons (car s)
- (gen-pslot
- (if (meta-model:foreign-key-p model (car s))
- 'foreign-key
- (cadr s))
- (string (car s)) (car s))))
- (meta-model:list-slot-types model))
- (mapcar #'(lambda (s)
- (cons s (append (gen-pslot 'has-many (string s) s)
- `(:presentation
- (make-presentation
- ,model
- :type :one-line)))))
- (meta-model:list-has-many model))
- (find-default-presentation-attribute-definitions)))
-
-(defmethod set-default-attributes ((model t))
- "Set the default attributes for MODEL"
- (clear-attributes model)
- (mapcar #'(lambda (x)
- (setf (find-attribute model (car x)) (cdr x)))
- (find-default-attributes model)))
+
;;;presentations
(defcomponent mewa ()
(mapcar #'class-name
(it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
-(defun make-attribute (&rest props &key type &allow-other-keys)
- (remf props :type)
- (cons (gensym) (cons type props)))
-
(defun make-presentation-for-attribute-list-item
(occurence att-name plist parent-presentation &optional type)
(declare (type list plist) (type symbol att-name))
plist
(plist-union
(global-properties parent-presentation)
- (attribute.plist attribute)))
+ (attribute.properties attribute)))
(list :size 30 :parent parent-presentation))))))
(defmethod find-applicable-attributes-using-attribute-list (occurence attribute-list)
(attribute.type a)
type)
(plist-union initargs (when a
- (attribute.plist a))))))
+ (attribute.properties a))))))
(setf (slot-value i 'instance) object)
(initialize-slots i)
(render-on res (slot-value self 'body)))
-
-
(defaction cancel-save-instance ((self mewa))
(cond
((meta-model::persistentp (instance self))