[clinton/lisp-on-lines.git] / src / mewa.lisp

(in-package :lisp-on-lines)

;;;; * Occurences
;;;; Occurences can be thought of as the class of a description. 
;;;; Most of the occurence stuff is depreciated now.

     "an occurence holds the attributes like a class holds slot-definitions.
Attributes are the yetadata 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 ((description (find-description name)))
    (if description
	(class-of description)
	(class-of (ensure-description name)))))

(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))
    (multiple-value-bind (occ new?)
	(find-or-create-occurence (class-name-of instance))
      (if new?
	  (initialize-occurence-for-instance occ instance)
	  occ))))

(defun list-attributes (occurence)
  (let (res)
    (maphash (lambda (k v)
	       (declare (ignore v))
	       (push k res))
	     (attribute-map occurence))
    res))


(defmethod make-attribute-using-slot-definition (slotd)
  (make-attribute
   :name (closer-mop:slot-definition-name slotd)
   :type-spec (closer-mop:slot-definition-type slotd)
   :type (first (remove-if (lambda (item)
			     (or
			      (eql item 'or)
			      (eql item 'null)
			      (eql item nil)))
			   (ensure-list (closer-mop:slot-definition-type slotd))))))

(defmethod initialize-occurence-for-instance (occurence instance)
  (let ((slots (closer-mop:class-slots (class-of instance))))
    (dolist (s slots)
      (let ((att (make-attribute-using-slot-definition s)))
	(setf (find-attribute occurence (attribute-name att)) att)))
    occurence))


;;;; * Attributes

(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)))


(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)
     (typespec :accessor type-spec :initarg :type-spec :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 description) &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 description) 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 description))
  (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)))))


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