src/mewa.lisp

(in-package :lisp-on-lines)

(define-layered-class description ()
  ((description-type
    :initarg :type
    :accessor description.type
    :initform 'viewer
    :special t)
   (description-layers
    :initarg :layers
    :accessor description.layers
    :initform nil
    :special t)
   (description-properties
    :accessor description.properties
    :initform nil
    :special t
    :documentation "TODO: not used much anymore, and shouldn't be relied on")
   (described-object
    :layered-accessor object
    :initform nil
    :special t)
   (description-default-attributes
    :accessor default-attributes
    :initarg :default-attributes
    :initform nil
    :special t)
   (description-attributes
    :accessor attributes
    :initarg :attributes
    :initform nil
    :special t)
   (description-default-properties
    :accessor default-properties
    :initarg :default-properties
    :initform '()
    :special t)))

(defmethod attributes :around ((description description))
  "Add any default properties to the attributes"

  (let ((default-properties (default-properties description)))
    (if (and (listp default-properties)
	     (not (null default-properties)))
	(let ((a (mapcar #'(lambda (att)
		    (append (ensure-list att) default-properties))
		(call-next-method))))


	  a)
	(call-next-method))))

(defmethod print-object ((self description) stream)
  (print-unreadable-object (self stream :type t)
    (with-slots (description-type) self
      (format stream "~A" description-type))))

;;;; * Occurences

(defvar *occurence-map* (make-hash-table)
  "a display is generated by associating an 'occurence'
with an instance of a class. This is usually keyed off class-name,
although an arbitrary occurence could be used with an arbitrary class.")

(define-layered-class
    standard-occurence (description)
    ((occurence-name :accessor name :initarg :name)
     (attribute-map :accessor attribute-map :initform (make-hash-table)))
    (:documentation
     "an occurence holds the attributes like a class holds slot-definitions.
Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."))

(defun find-or-create-occurence (name)
  "Returns the occurence associated with this name."
  (let ((occurence (gethash name *occurence-map*)))
    (if occurence
	occurence
	(let ((new-occurence (make-instance 'standard-occurence :name name)))
	  (setf (gethash name *occurence-map*) new-occurence)
	  new-occurence))))

(defun clear-occurence (occurence)
  "removes all attributes from the occurence"
  (setf (attribute-map occurence) (make-hash-table)))

(defgeneric find-occurence (name)
  (:method (thing)
    nil)
  (:method ((name symbol))
    (find-or-create-occurence name))
  (:method ((instance standard-object))
    (find-or-create-occurence (class-name (class-of instance)))))


(define-layered-class
    attribute (description)
    ((attribute-name :layered-accessor attribute.name
	   :initarg :name
	   :initform (gensym "ATTRIBUTE-")
	   :special t)
     (occurence :accessor occurence :initarg :occurence :initform nil)
     (label :initarg :label :layered-accessor label :initform nil :special t)))


;;;; * Attributes
(defmethod print-object ((self attribute) stream)
  (print-unreadable-object (self stream :type t)
    (with-slots (attribute-name description-type) self
      (format stream "~A ~A" description-type attribute-name))))

(define-layered-class
    standard-attribute (attribute)
    ((setter :accessor setter :initarg :setter :special t :initform nil)
     (getter :accessor getter :initarg :getter :special t :initform nil)
     (value :accessor value :initarg :value :special t)
     (slot-name :accessor slot-name :initarg :slot-name :special t :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."))

(define-layered-method label :around ((attribute standard-attribute))
 (or (call-next-method) (attribute.name attribute)))

(defmacro defattribute (name supers slots &rest args)
  (let* (
	(type-provided-p (second (assoc :type-name args)))
	(type (or type-provided-p name))
	(layer (or (second (assoc :in-layer args)) nil))
	(properties (cdr (assoc :default-properties args)))
	(cargs (remove-if #'(lambda (key)
		   (or (eql key :type-name)
		       (eql key :default-properties)
		       (eql key :default-initargs)
		       (eql key :in-layer)))
			 args
	       :key #'car)))

    `(progn
      (define-layered-class
	  ;;;; TODO: fix the naive way of making sure s-a is a superclass
	  ;;;; Need some MOPey goodness.
	  ,name ,@ (when layer `(:in-layer ,layer)),(or supers '(standard-attribute))
	  ,(append slots (properties-as-slots properties))
	  #+ (or) ,@ (cdr cargs)
	  ,@cargs
	  (:default-initargs :properties (list ,@properties)
	    ,@ (cdr (assoc :default-initargs args))))

      ,(when (or
	     type-provided-p
	     (not (find-attribute-class-for-type name)))
	 `(defmethod find-attribute-class-for-type ((type (eql ',type)))
	   ',name)))))

(defun clear-attributes (name)
  "removes all attributes from an occurance"
  (clear-occurence (find-occurence name)))

(defmethod find-attribute-class-for-type (type)
  nil)

(defun make-attribute (&rest args &key type &allow-other-keys)
  (apply #'make-instance
	 (or (find-attribute-class-for-type type)
	     'standard-attribute)
	 :properties args
	 args))

(defmethod ensure-attribute ((occurence standard-occurence) &rest args &key name &allow-other-keys)
  "Creates an attribute in the given occurence"
  (let ((attribute (apply #'make-attribute :occurence occurence args)))
    (setf (find-attribute occurence name) attribute)))

(defmethod find-attribute ((occurence null) name)
  nil)

(defmethod find-attribute ((occurence standard-occurence) name)
  (or (gethash name (attribute-map occurence))
      (let* ((class (ignore-errors (find-class (name occurence))))
	     (class-direct-superclasses
	      (when class
		(closer-mop:class-direct-superclasses
		 class))))
	(when class-direct-superclasses
	  (let ((attribute
		 (find-attribute
		  (find-occurence (class-name
				   (car
				    class-direct-superclasses)))
		  name)))
	    attribute)))))

(defmethod find-all-attributes ((occurence standard-occurence))
  (loop for att being the hash-values of (attribute-map occurence)
     collect att))

(defmethod ensure-attribute (occurence-name &rest args &key name type &allow-other-keys)
  (declare (ignore name type))
  (apply #'ensure-attribute
   (find-occurence occurence-name)
   args))

;;;; The following functions make up the public interface to the
;;;; MEWA Attribute Occurence system.

(defmethod find-all-attributes (occurence-name)
  (find-all-attributes (find-occurence occurence-name)))

(defmethod find-attribute (occurence-name attribute-name)
  "Return the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name"
  (find-attribute (find-occurence occurence-name) attribute-name))

(defmethod (setf find-attribute) ((attribute-spec list) occurence-name attribute-name)
  "Create a new attribute in the occurence.
ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
  (apply #'ensure-attribute occurence-name :name attribute-name :type (first attribute-spec) (rest attribute-spec)))

(defmethod (setf find-attribute) ((attribute standard-attribute) occurence attribute-name)
  "Create a new attribute in the occurence.
ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
  (setf (gethash attribute-name (attribute-map occurence))
	  attribute))

(defmethod (setf find-attribute) ((attribute null) occurence attribute-name)
  "Create a new attribute in the occurence.
ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
  (setf (gethash attribute-name (attribute-map occurence))
	  attribute))

(defmethod find-attribute ((attribute-with-occurence attribute) attribute-name)
  (find-attribute (occurence attribute-with-occurence) attribute-name))

(defmethod set-attribute-properties ((occurence-name t) attribute properties)
  (setf (description.properties attribute) (plist-nunion
					    properties
					    (description.properties attribute)))
  (loop for (initarg value) on (description.properties attribute)
	      by #'cddr
	      with map = (initargs.slot-names attribute)
	      do (let ((s-n (assoc-if #'(lambda (x) (member initarg x)) map)))

		   (if s-n
		       (progn
			 (setf (slot-value attribute
					   (cdr s-n))
			       value))
		       (warn "Cannot find initarg ~A in attribute ~S" initarg attribute)))
	      finally (return attribute)))

(defmethod set-attribute (occurence-name attribute-name attribute-spec &key (inherit t))
  "If inherit is T, sets the properties of the attribute only, unless the type has changed.
otherwise, (setf find-attribute)"
  (let ((att (find-attribute occurence-name attribute-name)))
    (if (and att inherit (or (eql (car attribute-spec)
			      (description.type att))
			     (eq (car attribute-spec) t)))
	(set-attribute-properties occurence-name att (cdr attribute-spec))
	(setf (find-attribute occurence-name attribute-name)
	      (cons  (car attribute-spec)
		     (plist-nunion
		      (cdr attribute-spec)
		      (when att (description.properties att))))))))

(defmethod perform-define-attributes ((occurence-name t) attributes)
  (loop for attribute in attributes
	do (destructuring-bind (name type &rest args)
		  attribute
	     (cond ((not (null type))
		    ;;set the type as well
		    (set-attribute occurence-name name (cons type args)))))))

(defmacro define-attributes (occurence-names &body attribute-definitions)
  `(progn
    ,@(loop for occurence-name in occurence-names
	    collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions)))))


(defmethod find-description (object type)
  (let ((occurence (find-occurence object)))
	occurence))

;;"Unused???"
(defmethod setter (attribute)
  (warn "Setting ~A in ~A" attribute *context*)
  (let ((setter (getf (description.properties attribute) :setter))
	(slot-name (getf (description.properties attribute) :slot-name)))
    (cond (setter
	   setter)
	  (slot-name
	   #'(lambda (value object)
	       (setf (slot-value object slot-name) value)))
	  (t
	   #'(lambda (value object)
	       (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute))))))


(define-layered-function attribute-value (instance attribute)
  (:documentation " Like SLOT-VALUE for instances, the base method calls GETTER."))

(defmethod attribute-slot-value (instance attribute)
  "Return (VALUES slot-value-or-nil existsp boundp

If this attribute, in its current context, refers to a slot,
we return slot-value-or nil either boundp or not."
  (let (existsp boundp slot-value-or-nil)
    (cond
      ((and (slot-boundp attribute 'slot-name) (slot-name attribute))
	 (when (slot-exists-p instance (slot-name attribute))
	   (setf existsp t)
	   (when (slot-boundp instance (slot-name attribute))
	     (setf boundp t
		   slot-value-or-nil (slot-value
				      instance
				      (slot-name attribute))))))
	((and (slot-exists-p instance (attribute.name attribute)))
	 (setf existsp t)
	 (when (slot-boundp instance (attribute.name attribute))
	   (setf boundp t
		 slot-value-or-nil (slot-value
				    instance
				    (attribute.name attribute))))))
    (VALUES slot-value-or-nil existsp boundp)))

(define-layered-method attribute-value (instance (attribute standard-attribute))
 "return the attribute value or NIL if it cannot be found"
    (with-slots (getter value) attribute
      (when (slot-boundp attribute 'value)
	(setf getter (constantly value)))
      (if (and (slot-boundp attribute 'getter) getter)
	  ;;;; call the getter
	  (funcall getter instance)
	  ;;;; or default to the attribute-slot-value
	  (attribute-slot-value instance attribute))))

(define-layered-function (setf attribute-value) (value instance attribute))

(define-layered-method
    (setf attribute-value) (value instance (attribute standard-attribute))
  (with-slots (setter slot-name) attribute
    (cond ((and (slot-boundp attribute 'setter) setter)
	   (funcall setter value instance))
	  ((and (slot-boundp attribute 'slot-name) slot-name)
	   (setf (slot-value instance slot-name) value))
	  ((and (slot-exists-p instance (attribute.name attribute)))
	   (setf (slot-value instance (attribute.name attribute)) value))
	  (t
	   (error "Cannot set ~A in ~A" attribute instance)))))


;;;; ** Default Attributes
;;;; TODO: This is mosty an ugly hack and should be reworked.
;;;;
;;;; The default mewa class contains the types use as defaults.
;;;; maps meta-model slot-types to slot-presentation

(defvar *default-attributes-class-name* 'default)

(defmacro with-default-attributes ((occurence-name) &body body)
  `(let ((*default-attributes-class-name* ',occurence-name))
    ,@body))

(define-attributes (default)
  (boolean boolean)
  (string string)
  (number currency)
  (integer   integer)
  (currency  currency)
  (clsql:generalized-boolean boolean)
  (foreign-key has-a))

(defun attribute-to-definition (attribute)
  (nconc (list (attribute.name attribute)
	       (description.type attribute))
	 (description.properties attribute)))

(defun find-default-presentation-attribute-definitions ()
  nil)

(defun gen-ptype (type)
  (let* ((type (if (consp type) (car type) type))
	 (possible-default (find-attribute *default-attributes-class-name* type))
	 (real-default (find-attribute 'default type)))
    (cond
      (possible-default
	(description.type possible-default))
       (real-default
	(description.type real-default))
       (t type))))

(defun gen-presentation-slots (instance)
  (mapcar #'(lambda (x) (gen-pslot (cadr x)
				   (string (car x))
				   (car x)))
	  (meta-model:list-slot-types instance)))


(defun gen-pslot (type label slot-name)
  (copy-list `(,(gen-ptype type)
	       :label ,label
	       :slot-name ,slot-name)))

;; This software is Copyright (c) Drew Crampsie, 2004-2005.
Commit	Line	Data
	1	(in-package :lisp-on-lines)
	2
	3	(define-layered-class description ()
	4	((description-type
	5	:initarg :type
	6	:accessor description.type
	7	:initform 'viewer
	8	:special t)
	9	(description-layers
	10	:initarg :layers
	11	:accessor description.layers
	12	:initform nil
	13	:special t)
	14	(description-properties
	15	:accessor description.properties
	16	:initform nil
	17	:special t
	18	:documentation "TODO: not used much anymore, and shouldn't be relied on")
	19	(described-object
	20	:layered-accessor object
	21	:initform nil
	22	:special t)
	23	(description-default-attributes
	24	:accessor default-attributes
	25	:initarg :default-attributes
	26	:initform nil
	27	:special t)
	28	(description-attributes
	29	:accessor attributes
	30	:initarg :attributes
	31	:initform nil
	32	:special t)
	33	(description-default-properties
	34	:accessor default-properties
	35	:initarg :default-properties
	36	:initform '()
	37	:special t)))
	38
	39	(defmethod attributes :around ((description description))
	40	"Add any default properties to the attributes"
	41
	42	(let ((default-properties (default-properties description)))
	43	(if (and (listp default-properties)
	44	(not (null default-properties)))
	45	(let ((a (mapcar #'(lambda (att)
	46	(append (ensure-list att) default-properties))
	47	(call-next-method))))
	48
	49
	50	a)
	51	(call-next-method))))
	52
	53	(defmethod print-object ((self description) stream)
	54	(print-unreadable-object (self stream :type t)
	55	(with-slots (description-type) self
	56	(format stream "~A" description-type))))
	57
	58	;;;; * Occurences
	59
	60	(defvar occurence-map (make-hash-table)
	61	"a display is generated by associating an 'occurence'
	62	with an instance of a class. This is usually keyed off class-name,
	63	although an arbitrary occurence could be used with an arbitrary class.")
	64
	65	(define-layered-class
	66	standard-occurence (description)
	67	((occurence-name :accessor name :initarg :name)
	68	(attribute-map :accessor attribute-map :initform (make-hash-table)))
	69	(:documentation
	70	"an occurence holds the attributes like a class holds slot-definitions.
	71	Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."))
	72
	73	(defun find-or-create-occurence (name)
	74	"Returns the occurence associated with this name."
	75	(let ((occurence (gethash name occurence-map)))
	76	(if occurence
	77	occurence
	78	(let ((new-occurence (make-instance 'standard-occurence :name name)))
	79	(setf (gethash name occurence-map) new-occurence)
	80	new-occurence))))
	81
	82	(defun clear-occurence (occurence)
	83	"removes all attributes from the occurence"
	84	(setf (attribute-map occurence) (make-hash-table)))
	85
	86	(defgeneric find-occurence (name)
	87	(:method (thing)
	88	nil)
	89	(:method ((name symbol))
	90	(find-or-create-occurence name))
	91	(:method ((instance standard-object))
	92	(find-or-create-occurence (class-name (class-of instance)))))
	93
	94
	95	(define-layered-class
	96	attribute (description)
	97	((attribute-name :layered-accessor attribute.name
	98	:initarg :name
	99	:initform (gensym "ATTRIBUTE-")
	100	:special t)
	101	(occurence :accessor occurence :initarg :occurence :initform nil)
	102	(label :initarg :label :layered-accessor label :initform nil :special t)))
	103
	104
	105	;;;; * Attributes
	106	(defmethod print-object ((self attribute) stream)
	107	(print-unreadable-object (self stream :type t)
	108	(with-slots (attribute-name description-type) self
	109	(format stream "~A ~A" description-type attribute-name))))
	110
	111	(define-layered-class
	112	standard-attribute (attribute)
	113	((setter :accessor setter :initarg :setter :special t :initform nil)
	114	(getter :accessor getter :initarg :getter :special t :initform nil)
	115	(value :accessor value :initarg :value :special t)
	116	(slot-name :accessor slot-name :initarg :slot-name :special t :initform nil))
	117	(: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."))
	118
	119	(define-layered-method label :around ((attribute standard-attribute))
	120	(or (call-next-method) (attribute.name attribute)))
	121
	122	(defmacro defattribute (name supers slots &rest args)
	123	(let* (
	124	(type-provided-p (second (assoc :type-name args)))
	125	(type (or type-provided-p name))
	126	(layer (or (second (assoc :in-layer args)) nil))
	127	(properties (cdr (assoc :default-properties args)))
	128	(cargs (remove-if #'(lambda (key)
	129	(or (eql key :type-name)
	130	(eql key :default-properties)
	131	(eql key :default-initargs)
	132	(eql key :in-layer)))
	133	args
	134	:key #'car)))
	135
	136	`(progn
	137	(define-layered-class
	138	;;;; TODO: fix the naive way of making sure s-a is a superclass
	139	;;;; Need some MOPey goodness.
	140	,name ,@ (when layer `(:in-layer ,layer)),(or supers '(standard-attribute))
	141	,(append slots (properties-as-slots properties))
	142	#+ (or) ,@ (cdr cargs)
	143	,@cargs
	144	(:default-initargs :properties (list ,@properties)
	145	,@ (cdr (assoc :default-initargs args))))
	146
	147	,(when (or
	148	type-provided-p
	149	(not (find-attribute-class-for-type name)))
	150	`(defmethod find-attribute-class-for-type ((type (eql ',type)))
	151	',name)))))
	152
	153	(defun clear-attributes (name)
	154	"removes all attributes from an occurance"
	155	(clear-occurence (find-occurence name)))
	156
	157	(defmethod find-attribute-class-for-type (type)
	158	nil)
	159
	160	(defun make-attribute (&rest args &key type &allow-other-keys)
	161	(apply #'make-instance
	162	(or (find-attribute-class-for-type type)
	163	'standard-attribute)
	164	:properties args
	165	args))
	166
	167	(defmethod ensure-attribute ((occurence standard-occurence) &rest args &key name &allow-other-keys)
	168	"Creates an attribute in the given occurence"
	169	(let ((attribute (apply #'make-attribute :occurence occurence args)))
	170	(setf (find-attribute occurence name) attribute)))
	171
	172	(defmethod find-attribute ((occurence null) name)
	173	nil)
	174
	175	(defmethod find-attribute ((occurence standard-occurence) name)
	176	(or (gethash name (attribute-map occurence))
	177	(let* ((class (ignore-errors (find-class (name occurence))))
	178	(class-direct-superclasses
	179	(when class
	180	(closer-mop:class-direct-superclasses
	181	class))))
	182	(when class-direct-superclasses
	183	(let ((attribute
	184	(find-attribute
	185	(find-occurence (class-name
	186	(car
	187	class-direct-superclasses)))
	188	name)))
	189	attribute)))))
	190
	191	(defmethod find-all-attributes ((occurence standard-occurence))
	192	(loop for att being the hash-values of (attribute-map occurence)
	193	collect att))
	194
	195	(defmethod ensure-attribute (occurence-name &rest args &key name type &allow-other-keys)
	196	(declare (ignore name type))
	197	(apply #'ensure-attribute
	198	(find-occurence occurence-name)
	199	args))
	200
	201	;;;; The following functions make up the public interface to the
	202	;;;; MEWA Attribute Occurence system.
	203
	204	(defmethod find-all-attributes (occurence-name)
	205	(find-all-attributes (find-occurence occurence-name)))
	206
	207	(defmethod find-attribute (occurence-name attribute-name)
	208	"Return the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name"
	209	(find-attribute (find-occurence occurence-name) attribute-name))
	210
	211	(defmethod (setf find-attribute) ((attribute-spec list) occurence-name attribute-name)
	212	"Create a new attribute in the occurence.
	213	ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
	214	(apply #'ensure-attribute occurence-name :name attribute-name :type (first attribute-spec) (rest attribute-spec)))
	215
	216	(defmethod (setf find-attribute) ((attribute standard-attribute) occurence attribute-name)
	217	"Create a new attribute in the occurence.
	218	ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
	219	(setf (gethash attribute-name (attribute-map occurence))
	220	attribute))
	221
	222	(defmethod (setf find-attribute) ((attribute null) occurence attribute-name)
	223	"Create a new attribute in the occurence.
	224	ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
	225	(setf (gethash attribute-name (attribute-map occurence))
	226	attribute))
	227
	228	(defmethod find-attribute ((attribute-with-occurence attribute) attribute-name)
	229	(find-attribute (occurence attribute-with-occurence) attribute-name))
	230
	231	(defmethod set-attribute-properties ((occurence-name t) attribute properties)
	232	(setf (description.properties attribute) (plist-nunion
	233	properties
	234	(description.properties attribute)))
	235	(loop for (initarg value) on (description.properties attribute)
	236	by #'cddr
	237	with map = (initargs.slot-names attribute)
	238	do (let ((s-n (assoc-if #'(lambda (x) (member initarg x)) map)))
	239
	240	(if s-n
	241	(progn
	242	(setf (slot-value attribute
	243	(cdr s-n))
	244	value))
	245	(warn "Cannot find initarg ~A in attribute ~S" initarg attribute)))
	246	finally (return attribute)))
	247
	248	(defmethod set-attribute (occurence-name attribute-name attribute-spec &key (inherit t))
	249	"If inherit is T, sets the properties of the attribute only, unless the type has changed.
	250	otherwise, (setf find-attribute)"
	251	(let ((att (find-attribute occurence-name attribute-name)))
	252	(if (and att inherit (or (eql (car attribute-spec)
	253	(description.type att))
	254	(eq (car attribute-spec) t)))
	255	(set-attribute-properties occurence-name att (cdr attribute-spec))
	256	(setf (find-attribute occurence-name attribute-name)
	257	(cons (car attribute-spec)
	258	(plist-nunion
	259	(cdr attribute-spec)
	260	(when att (description.properties att))))))))
	261
	262	(defmethod perform-define-attributes ((occurence-name t) attributes)
	263	(loop for attribute in attributes
	264	do (destructuring-bind (name type &rest args)
	265	attribute
	266	(cond ((not (null type))
	267	;;set the type as well
	268	(set-attribute occurence-name name (cons type args)))))))
	269
	270	(defmacro define-attributes (occurence-names &body attribute-definitions)
	271	`(progn
	272	,@(loop for occurence-name in occurence-names
	273	collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions)))))
	274
	275
	276	(defmethod find-description (object type)
	277	(let ((occurence (find-occurence object)))
	278	occurence))
	279
	280	;;"Unused???"
	281	(defmethod setter (attribute)
	282	(warn "Setting ~A in ~A" attribute context)
	283	(let ((setter (getf (description.properties attribute) :setter))
	284	(slot-name (getf (description.properties attribute) :slot-name)))
	285	(cond (setter
	286	setter)
	287	(slot-name
	288	#'(lambda (value object)
	289	(setf (slot-value object slot-name) value)))
	290	(t
	291	#'(lambda (value object)
	292	(warn "Can't find anywere to set ~A in ~A using ~A" value object attribute))))))
	293
	294
	295	(define-layered-function attribute-value (instance attribute)
	296	(:documentation " Like SLOT-VALUE for instances, the base method calls GETTER."))
	297
	298	(defmethod attribute-slot-value (instance attribute)
	299	"Return (VALUES slot-value-or-nil existsp boundp
	300
	301	If this attribute, in its current context, refers to a slot,
	302	we return slot-value-or nil either boundp or not."
	303	(let (existsp boundp slot-value-or-nil)
	304	(cond
	305	((and (slot-boundp attribute 'slot-name) (slot-name attribute))
	306	(when (slot-exists-p instance (slot-name attribute))
	307	(setf existsp t)
	308	(when (slot-boundp instance (slot-name attribute))
	309	(setf boundp t
	310	slot-value-or-nil (slot-value
	311	instance
	312	(slot-name attribute))))))
	313	((and (slot-exists-p instance (attribute.name attribute)))
	314	(setf existsp t)
	315	(when (slot-boundp instance (attribute.name attribute))
	316	(setf boundp t
	317	slot-value-or-nil (slot-value
	318	instance
	319	(attribute.name attribute))))))
	320	(VALUES slot-value-or-nil existsp boundp)))
	321
	322	(define-layered-method attribute-value (instance (attribute standard-attribute))
	323	"return the attribute value or NIL if it cannot be found"
	324	(with-slots (getter value) attribute
	325	(when (slot-boundp attribute 'value)
	326	(setf getter (constantly value)))
	327	(if (and (slot-boundp attribute 'getter) getter)
	328	;;;; call the getter
	329	(funcall getter instance)
	330	;;;; or default to the attribute-slot-value
	331	(attribute-slot-value instance attribute))))
	332
	333	(define-layered-function (setf attribute-value) (value instance attribute))
	334
	335	(define-layered-method
	336	(setf attribute-value) (value instance (attribute standard-attribute))
	337	(with-slots (setter slot-name) attribute
	338	(cond ((and (slot-boundp attribute 'setter) setter)
	339	(funcall setter value instance))
	340	((and (slot-boundp attribute 'slot-name) slot-name)
	341	(setf (slot-value instance slot-name) value))
	342	((and (slot-exists-p instance (attribute.name attribute)))
	343	(setf (slot-value instance (attribute.name attribute)) value))
	344	(t
	345	(error "Cannot set ~A in ~A" attribute instance)))))
	346
	347
	348
	349	;;;; ** Default Attributes
	350	;;;; TODO: This is mosty an ugly hack and should be reworked.
	351	;;;;
	352	;;;; The default mewa class contains the types use as defaults.
	353	;;;; maps meta-model slot-types to slot-presentation
	354
	355	(defvar default-attributes-class-name 'default)
	356
	357	(defmacro with-default-attributes ((occurence-name) &body body)
	358	`(let ((default-attributes-class-name ',occurence-name))
	359	,@body))
	360
	361	(define-attributes (default)
	362	(boolean boolean)
	363	(string string)
	364	(number currency)
	365	(integer integer)
	366	(currency currency)
	367	(clsql:generalized-boolean boolean)
	368	(foreign-key has-a))
	369
	370	(defun attribute-to-definition (attribute)
	371	(nconc (list (attribute.name attribute)
	372	(description.type attribute))
	373	(description.properties attribute)))
	374
	375	(defun find-default-presentation-attribute-definitions ()
	376	nil)
	377
	378	(defun gen-ptype (type)
	379	(let* ((type (if (consp type) (car type) type))
	380	(possible-default (find-attribute default-attributes-class-name type))
	381	(real-default (find-attribute 'default type)))
	382	(cond
	383	(possible-default
	384	(description.type possible-default))
	385	(real-default
	386	(description.type real-default))
	387	(t type))))
	388
	389	(defun gen-presentation-slots (instance)
	390	(mapcar #'(lambda (x) (gen-pslot (cadr x)
	391	(string (car x))
	392	(car x)))
	393	(meta-model:list-slot-types instance)))
	394
	395
	396	(defun gen-pslot (type label slot-name)
	397	(copy-list `(,(gen-ptype type)
	398	:label ,label
	399	:slot-name ,slot-name)))
	400
	401	;; This software is Copyright (c) Drew Crampsie, 2004-2005.