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 stream
"~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 could 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
292 If this attribute, in its current context, refers to a slot,
293 we return slot-value-or nil either boundp or not."
294 (let (existsp boundp slot-value-or-nil
)
296 ((and (slot-boundp attribute
'slot-name
) (slot-name attribute
))
297 (when (slot-exists-p instance
(slot-name attribute
))
299 (when (slot-boundp instance
(slot-name attribute
))
301 slot-value-or-nil
(slot-value
303 (slot-name attribute
))))))
304 ((and (slot-exists-p instance
(attribute.name attribute
)))
306 (when (slot-boundp instance
(attribute.name attribute
))
308 slot-value-or-nil
(slot-value
310 (attribute.name attribute
))))))
311 (VALUES slot-value-or-nil existsp boundp
)))
313 (define-layered-method attribute-value
(instance (attribute standard-attribute
))
314 "return the attribute value or NIL if it cannot be found"
315 (with-slots (getter value
) attribute
316 (when (slot-boundp attribute
'value
)
317 (setf getter
(constantly value
)))
318 (if (and (slot-boundp attribute
'getter
) getter
)
320 (funcall getter instance
)
321 ;;;; or default to the attribute-slot-value
322 (attribute-slot-value instance attribute
))))
324 (define-layered-function (setf attribute-value
) (value instance attribute
))
326 (define-layered-method
327 (setf attribute-value
) (value instance
(attribute standard-attribute
))
328 (with-slots (setter slot-name
) attribute
329 (cond ((and (slot-boundp attribute
'setter
) setter
)
330 (funcall setter value instance
))
331 ((and (slot-boundp attribute
'slot-name
) slot-name
)
332 (setf (slot-value instance slot-name
) value
))
333 ((and (slot-exists-p instance
(attribute.name attribute
)))
334 (setf (slot-value instance
(attribute.name attribute
)) value
))
336 (error "Cannot set ~A in ~A" attribute instance
)))))
340 ;;;; ** Default Attributes
343 ;;;; The default mewa class contains the types use as defaults.
344 ;;;; maps meta-model slot-types to slot-presentation
346 (defvar *default-attributes-class-name
* 'default
)
348 (defmacro with-default-attributes
((occurence-name) &body body
)
349 `(let ((*default-attributes-class-name
* ',occurence-name
))
352 (define-attributes (default)
358 (clsql:generalized-boolean boolean
)
359 (foreign-key foreign-key
))
361 (defun find-presentation-attributes (occurence-name)
362 (loop for att in
(find-all-attributes occurence-name
)
363 when
(typep att
'display-attribute
)
366 (defun attribute-to-definition (attribute)
367 (nconc (list (attribute.name attribute
)
368 (description.type attribute
))
369 (description.properties attribute
)))
371 (defun find-default-presentation-attribute-definitions ()
372 (if (eql *default-attributes-class-name
* 'default
)
373 (mapcar #'attribute-to-definition
(find-presentation-attributes 'default
))
374 (remove-duplicates (mapcar #'attribute-to-definition
376 (find-presentation-attributes 'default
)
377 (find-presentation-attributes
378 *default-attributes-class-name
*))))))
379 (defun gen-ptype (type)
380 (let* ((type (if (consp type
) (car type
) type
))
381 (possible-default (find-attribute *default-attributes-class-name
* type
))
382 (real-default (find-attribute 'default type
)))
385 (description.type possible-default
))
387 (description.type real-default
))
390 (defun gen-presentation-slots (instance)
391 (mapcar #'(lambda (x) (gen-pslot (cadr x
)
394 (meta-model:list-slot-types instance
)))
397 (defun gen-pslot (type label slot-name
)
398 (copy-list `(,(gen-ptype type
)
400 :slot-name
,slot-name
)))
402 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.