1 (in-package :lisp-on-lines
)
4 ;;;; Occurences can be thought of as the class of a description.
5 ;;;; Most of the occurence stuff is depreciated now.
7 "an occurence holds the attributes like a class holds slot-definitions.
8 Attributes are the yetadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."
10 (defun find-or-create-occurence (name)
11 "Returns the occurence associated with this name."
12 (let ((description (find-description name
)))
14 (class-of description
)
15 (class-of (ensure-description name
)))))
17 (defun clear-occurence (occurence)
18 "removes all attributes from the occurence"
19 (setf (attribute-map occurence
) (make-hash-table)))
21 (defgeneric find-occurence
(name)
24 (:method
((name symbol
))
25 (find-or-create-occurence name
))
26 (:method
((instance standard-object
))
27 (multiple-value-bind (occ new?
)
28 (find-or-create-occurence (class-name-of instance
))
30 (initialize-occurence-for-instance occ instance
)
33 (defun list-attributes (occurence)
35 (maphash (lambda (k v
)
38 (attribute-map occurence
))
42 (defmethod make-attribute-using-slot-definition (slotd)
44 :name
(closer-mop:slot-definition-name slotd
)
45 :type-spec
(closer-mop:slot-definition-type slotd
)
46 :type
(first (remove-if (lambda (item)
51 (ensure-list (closer-mop:slot-definition-type slotd
))))))
53 (defmethod initialize-occurence-for-instance (occurence instance
)
54 (let ((slots (closer-mop:class-slots
(class-of instance
))))
56 (let ((att (make-attribute-using-slot-definition s
)))
57 (setf (find-attribute occurence
(attribute-name att
)) att
)))
66 attribute
(description)
67 ((attribute-name :layered-accessor attribute-name
69 :initform
(gensym "ATTRIBUTE-")
71 (occurence :accessor occurence
:initarg
:occurence
:initform nil
)
72 (label :initarg
:label
:layered-accessor label
:initform nil
:special t
)))
75 (defmethod print-object ((self attribute
) stream
)
76 (print-unreadable-object (self stream
:type t
)
77 (with-slots (attribute-name description-type
) self
78 (format stream
"~A ~A" description-type attribute-name
))))
81 standard-attribute
(attribute)
82 ((setter :accessor setter
:initarg
:setter
:special t
:initform nil
)
83 (getter :accessor getter
:initarg
:getter
:special t
:initform nil
)
84 (value :accessor value
:initarg
:value
:special t
)
85 (slot-name :accessor slot-name
:initarg
:slot-name
:special t
:initform nil
)
86 (typespec :accessor type-spec
:initarg
:type-spec
:initform nil
))
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."))
89 (define-layered-method label
:around
((attribute standard-attribute
))
90 (or (call-next-method) (attribute-name attribute
)))
92 (defmacro defattribute
(name supers slots
&rest args
)
94 (type-provided-p (second (assoc :type-name args
)))
95 (type (or type-provided-p name
))
96 (layer (or (second (assoc :in-layer args
)) nil
))
97 (properties (cdr (assoc :default-properties args
)))
98 (cargs (remove-if #'(lambda (key)
99 (or (eql key
:type-name
)
100 (eql key
:default-properties
)
101 (eql key
:default-initargs
)
102 (eql key
:in-layer
)))
107 (define-layered-class
108 ;;;; TODO: fix the naive way of making sure s-a is a superclass
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
)
114 (:default-initargs
:properties
(list ,@properties
)
115 ,@ (cdr (assoc :default-initargs args
))))
119 (not (find-attribute-class-for-type name
)))
120 `(defmethod find-attribute-class-for-type ((type (eql ',type
)))
123 (defun clear-attributes (name)
124 "removes all attributes from an occurance"
125 (clear-occurence (find-occurence name
)))
127 (defmethod find-attribute-class-for-type (type)
130 (defun make-attribute (&rest args
&key type
&allow-other-keys
)
131 (apply #'make-instance
132 (or (find-attribute-class-for-type type
)
137 (defmethod ensure-attribute ((occurence description
) &rest args
&key name
&allow-other-keys
)
138 "Creates an attribute in the given occurence"
139 (let ((attribute (apply #'make-attribute
:occurence occurence args
)))
140 (setf (find-attribute occurence name
) attribute
)))
142 (defmethod find-attribute ((occurence null
) name
)
145 (defmethod find-attribute ((occurence description
) name
)
146 (or (gethash name
(attribute-map occurence
))
147 (let* ((class (ignore-errors (find-class (name occurence
))))
148 (class-direct-superclasses
150 (closer-mop:class-direct-superclasses
152 (when class-direct-superclasses
155 (find-occurence (class-name
157 class-direct-superclasses
)))
161 (defmethod find-all-attributes ((occurence description
))
162 (loop for att being the hash-values of
(attribute-map occurence
)
165 (defmethod ensure-attribute (occurence-name &rest args
&key name type
&allow-other-keys
)
166 (declare (ignore name type
))
167 (apply #'ensure-attribute
168 (find-occurence occurence-name
)
171 ;;;; The following functions make up the public interface to the
172 ;;;; MEWA Attribute Occurence system.
174 (defmethod find-all-attributes (occurence-name)
175 (find-all-attributes (find-occurence occurence-name
)))
177 (defmethod find-attribute (occurence-name attribute-name
)
178 "Return the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name"
179 (find-attribute (find-occurence occurence-name
) attribute-name
))
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
)))
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
))
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
))
198 (defmethod find-attribute ((attribute-with-occurence attribute
) attribute-name
)
199 (find-attribute (occurence attribute-with-occurence
) attribute-name
))
201 (defmethod set-attribute-properties ((occurence-name t
) attribute properties
)
202 (setf (description-properties attribute
) (plist-nunion
204 (description-properties attribute
)))
205 (loop for
(initarg value
) on
(description-properties attribute
)
207 with map
= (initargs.slot-names attribute
)
208 do
(let ((s-n (assoc-if #'(lambda (x) (member initarg x
)) map
)))
212 (setf (slot-value attribute
215 (warn "Cannot find initarg ~A in attribute ~S" initarg attribute
)))
216 finally
(return attribute
)))
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
)
223 (description-type att
))
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
)
230 (when att
(description-properties att
))))))))
232 (defmethod perform-define-attributes ((occurence-name t
) attributes
)
233 (loop for attribute in attributes
234 do
(destructuring-bind (name type
&rest args
)
236 (cond ((not (null type
))
237 ;;set the type as well
238 (set-attribute occurence-name name
(cons type args
)))))))
240 (defmacro define-attributes
(occurence-names &body attribute-definitions
)
242 ,@(loop for occurence-name in occurence-names
243 collect
`(perform-define-attributes (quote ,occurence-name
) (quote ,attribute-definitions
)))))
249 (defmethod setter (attribute)
250 (warn "Setting ~A in ~A" attribute
*context
*)
251 (let ((setter (getf (description-properties attribute
) :setter
))
252 (slot-name (getf (description-properties attribute
) :slot-name
)))
256 #'(lambda (value object
)
257 (setf (slot-value object slot-name
) value
)))
259 #'(lambda (value object
)
260 (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute
))))))
263 (define-layered-function attribute-value
(instance attribute
)
264 (:documentation
" Like SLOT-VALUE for instances, the base method calls GETTER."))
266 (defmethod attribute-slot-value (instance attribute
)
267 "Return (VALUES slot-value-or-nil existsp boundp
269 If this attribute, in its current context, refers to a slot,
270 we return slot-value-or nil either boundp or not."
271 (let (existsp boundp slot-value-or-nil
)
273 ((and (slot-boundp attribute
'slot-name
) (slot-name attribute
))
274 (when (slot-exists-p instance
(slot-name attribute
))
276 (when (slot-boundp instance
(slot-name attribute
))
278 slot-value-or-nil
(slot-value
280 (slot-name attribute
))))))
281 ((and (slot-exists-p instance
(attribute-name attribute
)))
283 (when (slot-boundp instance
(attribute-name attribute
))
285 slot-value-or-nil
(slot-value
287 (attribute-name attribute
))))))
288 (VALUES slot-value-or-nil existsp boundp
)))
290 (define-layered-method attribute-value
(instance (attribute standard-attribute
))
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
)
297 (funcall getter instance
)
298 ;;;; or default to the attribute-slot-value
299 (attribute-slot-value instance attribute
))))
301 (define-layered-function (setf attribute-value
) (value instance attribute
))
303 (define-layered-method
304 (setf attribute-value
) (value instance
(attribute standard-attribute
))
305 (with-slots (setter slot-name
) attribute
306 (cond ((and (slot-boundp attribute
'setter
) setter
)
307 (funcall setter value instance
))
308 ((and (slot-boundp attribute
'slot-name
) slot-name
)
309 (setf (slot-value instance slot-name
) value
))
310 ((and (slot-exists-p instance
(attribute-name attribute
)))
311 (setf (slot-value instance
(attribute-name attribute
)) value
))
313 (error "Cannot set ~A in ~A" attribute instance
)))))
317 ;;;; ** Default Attributes
318 ;;;; TODO: This is mosty an ugly hack and should be reworked.
320 ;;;; The default mewa class contains the types use as defaults.
321 ;;;; maps meta-model slot-types to slot-presentation
323 (defvar *default-attributes-class-name
* 'default
)
325 (defmacro with-default-attributes
((occurence-name) &body body
)
326 `(let ((*default-attributes-class-name
* ',occurence-name
))
329 (define-attributes (default)
335 (clsql:generalized-boolean boolean
)
338 (defun attribute-to-definition (attribute)
339 (nconc (list (attribute-name attribute
)
340 (description-type attribute
))
341 (description-properties attribute
)))
343 (defun find-default-presentation-attribute-definitions ()
346 (defun gen-ptype (type)
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
)))
352 (description-type possible-default
))
354 (description-type real-default
))
357 (defun gen-presentation-slots (instance)
358 (mapcar #'(lambda (x) (gen-pslot (cadr x
)
361 (meta-model:list-slot-types instance
)))
364 (defun gen-pslot (type label slot-name
)
365 (copy-list `(,(gen-ptype type
)
367 :slot-name
,slot-name
)))
369 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.