1 (declaim (optimize (speed 2) (space 3) (safety 0)))
3 (in-package :lisp-on-lines
)
5 (defparameter *default-type
* :ucw
)
7 (define-layered-class description
()
10 :accessor description.type
15 :accessor description.layers
18 (description-properties
19 :accessor description.properties
23 :layered-accessor object
26 (description-default-attributes
27 :accessor default-attributes
28 :initarg
:default-attributes
31 (description-attributes
37 (defmethod print-object ((self description
) stream
)
38 (print-unreadable-object (self stream
:type t
)
39 (with-slots (description-type) self
40 (format t
"~A" description-type
))))
44 (defvar *occurence-map
* (make-hash-table)
45 "a display is generated by associating an 'occurence'
46 with an instance of a class. This is usually keyed off class-name,
47 although an arbitrary occurence can be used with an arbitrary class.")
50 standard-occurence
(description)
51 ((occurence-name :accessor name
:initarg
:name
)
52 (attribute-map :accessor attribute-map
:initform
(make-hash-table)))
54 "an occurence holds the attributes like a class holds slot-definitions.
55 Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."))
57 (defun find-or-create-occurence (name)
58 "Returns the occurence associated with this name."
59 (let ((occurence (gethash name
*occurence-map
*)))
62 (let ((new-occurence (make-instance 'standard-occurence
:name name
)))
63 (setf (gethash name
*occurence-map
*) new-occurence
)
66 (defun clear-occurence (occurence)
67 "removes all attributes from the occurence"
68 (setf (attribute-map occurence
) (make-hash-table)))
70 (defgeneric find-occurence
(name)
73 (:method
((name symbol
))
74 (find-or-create-occurence name
))
75 (:method
((instance standard-object
))
76 (find-or-create-occurence (class-name (class-of instance
)))))
80 attribute
(description)
81 ((attribute-name :layered-accessor attribute.name
83 :initform
(gensym "ATTRIBUTE-")
85 (occurence :accessor occurence
:initarg
:occurence
:initform nil
)
86 (label :initarg
:label
:layered-accessor label
:initform nil
:special t
)))
89 (defmethod print-object ((self attribute
) stream
)
90 (print-unreadable-object (self stream
:type t
)
91 (with-slots (attribute-name description-type
) self
92 (format stream
"~A ~A" description-type attribute-name
))))
95 standard-attribute
(attribute)
96 ((setter :accessor setter
:initarg
:setter
:special t
:initform nil
)
97 (getter :accessor getter
:initarg
:getter
:special t
:initform nil
)
98 (value :accessor value
:initarg
:value
:special t
)
99 (slot-name :accessor slot-name
:initarg
:slot-name
:special t
:initform nil
))
100 (: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."))
102 (defmacro defattribute
(name supers slots
&rest args
)
104 (type-provided-p (second (assoc :type-name args
)))
105 (type (or type-provided-p name
))
106 (layer (or (second (assoc :in-layer args
)) nil
))
107 (properties (cdr (assoc :default-properties args
)))
108 (cargs (remove-if #'(lambda (key)
109 (or (eql key
:type-name
)
110 (eql key
:default-properties
)
111 (eql key
:default-initargs
)
112 (eql key
:in-layer
)))
117 (define-layered-class
118 ;;;; TODO: fix the naive way of making sure s-a is a superclass
119 ;;;; Need some MOPey goodness.
120 ,name
,@ (when layer
`(:in-layer
,layer
)),(or supers
'(standard-attribute))
121 ,(append slots
(properties-as-slots properties
))
122 #+ (or) ,@ (cdr cargs
)
124 (:default-initargs
:properties
(list ,@properties
)
125 ,@ (cdr (assoc :default-initargs args
))))
129 (not (find-attribute-class-for-type name
)))
130 `(defmethod find-attribute-class-for-type ((type (eql ',type
)))
132 (define-layered-class
133 display-attribute
(attribute)
135 (:documentation
"Presentation Attributes are used to display objects
136 using the attributes defined in an occurence. Presentation Attributes are always named using keywords."))
138 (defun clear-attributes (name)
139 "removes all attributes from an occurance"
140 (clear-occurence (find-occurence name
)))
142 (defmethod find-attribute-class-for-type (type)
145 (defun make-attribute (&rest args
&key type
&allow-other-keys
)
146 (apply #'make-instance
147 (or (find-attribute-class-for-type type
)
152 (defmethod ensure-attribute ((occurence standard-occurence
) &rest args
&key name
&allow-other-keys
)
153 "Creates an attribute in the given occurence"
154 (let ((attribute (apply #'make-attribute
:occurence occurence args
)))
155 (setf (find-attribute occurence name
) attribute
)))
157 (defmethod find-attribute ((occurence null
) name
)
160 (defmethod find-attribute ((occurence standard-occurence
) name
)
161 (or (gethash name
(attribute-map occurence
))
162 (let* ((class (ignore-errors (find-class (name occurence
))))
163 (class-direct-superclasses
165 (closer-mop:class-direct-superclasses
167 (when class-direct-superclasses
170 (find-occurence (class-name
172 class-direct-superclasses
)))
176 (defmethod find-all-attributes ((occurence standard-occurence
))
177 (loop for att being the hash-values of
(attribute-map occurence
)
180 (defmethod ensure-attribute (occurence-name &rest args
&key name type
&allow-other-keys
)
181 (declare (ignore name type
))
182 (apply #'ensure-attribute
183 (find-occurence occurence-name
)
186 ;;;; The following functions make up the public interface to the
187 ;;;; MEWA Attribute Occurence system.
189 (defmethod find-all-attributes (occurence-name)
190 (find-all-attributes (find-occurence occurence-name
)))
192 (defmethod find-attribute (occurence-name attribute-name
)
193 "Return the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name"
194 (find-attribute (find-occurence occurence-name
) attribute-name
))
196 (defmethod (setf find-attribute
) ((attribute-spec list
) occurence-name attribute-name
)
197 "Create a new attribute in the occurence.
198 ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
199 (apply #'ensure-attribute occurence-name
:name attribute-name
:type
(first attribute-spec
) (rest attribute-spec
)))
201 (defmethod (setf find-attribute
) ((attribute standard-attribute
) occurence attribute-name
)
202 "Create a new attribute in the occurence.
203 ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
204 (setf (gethash attribute-name
(attribute-map occurence
))
207 (defmethod (setf find-attribute
) ((attribute null
) occurence attribute-name
)
208 "Create a new attribute in the occurence.
209 ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
210 (setf (gethash attribute-name
(attribute-map occurence
))
214 (defmethod find-attribute ((attribute-with-occurence attribute
) attribute-name
)
215 (find-attribute (occurence attribute-with-occurence
) attribute-name
))
217 (defmethod set-attribute-properties ((occurence-name t
) attribute properties
)
218 (setf (description.properties attribute
) (plist-nunion
220 (description.properties attribute
)))
221 (loop for
(initarg value
) on
(description.properties attribute
)
223 with map
= (initargs.slot-names attribute
)
224 do
(let ((s-n (assoc-if #'(lambda (x) (member initarg x
)) map
)))
228 (setf (slot-value attribute
231 (warn "Cannot find initarg ~A in attribute ~S" initarg attribute
)))
232 finally
(return attribute
)))
234 (defmethod set-attribute (occurence-name attribute-name attribute-spec
&key
(inherit t
))
235 "If inherit is T, sets the properties of the attribute only, unless the type has changed.
236 otherwise, (setf find-attribute)"
237 (let ((att (find-attribute occurence-name attribute-name
)))
238 (if (and att inherit
(or (eql (car attribute-spec
)
239 (description.type att
))
240 (eq (car attribute-spec
) t
)))
241 (set-attribute-properties occurence-name att
(cdr attribute-spec
))
242 (setf (find-attribute occurence-name attribute-name
)
243 (cons (car attribute-spec
)
246 (when att
(description.properties att
))))))))
248 (defmethod perform-define-attributes ((occurence-name t
) attributes
)
249 (loop for attribute in attributes
250 do
(destructuring-bind (name type
&rest args
)
252 (cond ((not (null type
))
253 ;;set the type as well
254 (set-attribute occurence-name name
(cons type args
)))))))
256 (defmacro define-attributes
(occurence-names &body attribute-definitions
)
258 ,@(loop for occurence-name in occurence-names
259 collect
`(perform-define-attributes (quote ,occurence-name
) (quote ,attribute-definitions
)))))
261 (defmethod find-display-attribute (occurence name
)
262 (find-attribute occurence
(intern (symbol-name name
) "KEYWORD")))
264 (defmethod find-description (object type
)
265 (let ((occurence (find-occurence object
)))
266 (or (find-display-attribute
272 (defmethod setter (attribute)
273 (warn "Setting ~A in ~A" attribute
*context
*)
274 (let ((setter (getf (description.properties attribute
) :setter
))
275 (slot-name (getf (description.properties attribute
) :slot-name
)))
279 #'(lambda (value object
)
280 (setf (slot-value object slot-name
) value
)))
282 #'(lambda (value object
)
283 (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute
))))))
286 (define-layered-function attribute-value
(instance attribute
)
287 (:documentation
" Like SLOT-VALUE for instances, the base method calls GETTER."))
289 (defmethod attribute-slot-value (instance attribute
)
290 "Return (VALUES slot-value-or-nil existsp boundp"
291 (let (existsp boundp slot-value-or-nil
)
293 ((and (slot-boundp attribute
'slot-name
) (slot-name attribute
))
294 (when (slot-exists-p instance
(slot-name attribute
))
296 (when (slot-boundp instance
(slot-name attribute
))
298 slot-value-or-nil
(slot-value
300 (slot-name attribute
))))))
301 ((and (slot-exists-p instance
(attribute.name attribute
)))
303 (when (slot-boundp instance
(attribute.name attribute
))
305 slot-value-or-nil
(slot-value
307 (attribute.name attribute
))))))
308 (VALUES slot-value-or-nil existsp boundp
)))
310 (define-layered-method attribute-value
(instance (attribute standard-attribute
))
311 "return the attribute value or NIL if it cannot be found"
312 (with-slots (getter value
) attribute
313 (when (slot-boundp attribute
'value
)
314 (setf getter
(constantly value
)))
315 (if (and (slot-boundp attribute
'getter
) getter
)
317 (funcall getter instance
)
318 ;;;; or default to the attribute-slot-value
319 (attribute-slot-value instance attribute
))))
321 (define-layered-function (setf attribute-value
) (value instance attribute
))
323 (define-layered-method
324 (setf attribute-value
) (value instance
(attribute standard-attribute
))
325 (with-slots (setter slot-name
) attribute
326 (cond ((and (slot-boundp attribute
'setter
) setter
)
327 (funcall setter value instance
))
328 ((and (slot-boundp attribute
'slot-name
) slot-name
)
329 (setf (slot-value instance slot-name
) value
))
330 ((and (slot-exists-p instance
(attribute.name attribute
)))
331 (setf (slot-value instance
(attribute.name attribute
)) value
))
333 (error "Cannot set ~A in ~A" attribute instance
)))))
337 ;;;; ** Default Attributes
340 ;;;; The default mewa class contains the types use as defaults.
341 ;;;; maps meta-model slot-types to slot-presentation
343 (defvar *default-attributes-class-name
* 'default
)
345 (defmacro with-default-attributes
((occurence-name) &body body
)
346 `(let ((*default-attributes-class-name
* ',occurence-name
))
349 (define-attributes (default)
355 (clsql:generalized-boolean boolean
)
356 (foreign-key foreign-key
))
358 (defun find-presentation-attributes (occurence-name)
359 (loop for att in
(find-all-attributes occurence-name
)
360 when
(typep att
'display-attribute
)
363 (defun attribute-to-definition (attribute)
364 (nconc (list (attribute.name attribute
)
365 (description.type attribute
))
366 (description.properties attribute
)))
368 (defun find-default-presentation-attribute-definitions ()
369 (if (eql *default-attributes-class-name
* 'default
)
370 (mapcar #'attribute-to-definition
(find-presentation-attributes 'default
))
371 (remove-duplicates (mapcar #'attribute-to-definition
373 (find-presentation-attributes 'default
)
374 (find-presentation-attributes
375 *default-attributes-class-name
*))))))
376 (defun gen-ptype (type)
377 (let* ((type (if (consp type
) (car type
) type
))
378 (possible-default (find-attribute *default-attributes-class-name
* type
))
379 (real-default (find-attribute 'default type
)))
382 (description.type possible-default
))
384 (description.type real-default
))
387 (defun gen-presentation-slots (instance)
388 (mapcar #'(lambda (x) (gen-pslot (cadr x
)
391 (meta-model:list-slot-types instance
)))
394 (defun gen-pslot (type label slot-name
)
395 (copy-list `(,(gen-ptype type
)
397 :slot-name
,slot-name
)))
399 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.