1 (in-package :lisp-on-lines
)
3 (define-layered-class description
()
6 :accessor description.type
11 :accessor description.layers
14 (description-properties
15 :accessor description.properties
18 :documentation
"TODO: not used much anymore, and shouldn't be relied on")
20 :layered-accessor object
23 (description-default-attributes
24 :accessor default-attributes
25 :initarg
:default-attributes
28 (description-attributes
33 (description-default-properties
34 :accessor default-properties
35 :initarg
:default-properties
39 (defmethod attributes :around
((description description
))
40 "Add any default properties to the attributes"
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
))
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
))))
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.")
66 standard-occurence
(description)
67 ((occurence-name :accessor name
:initarg
:name
)
68 (attribute-map :accessor attribute-map
:initform
(make-hash-table)))
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."))
73 (defun find-or-create-occurence (name)
74 "Returns the occurence associated with this name."
75 (let ((occurence (gethash name
*occurence-map
*)))
78 (let ((new-occurence (make-instance 'standard-occurence
:name name
)))
79 (setf (gethash name
*occurence-map
*) new-occurence
)
82 (defun clear-occurence (occurence)
83 "removes all attributes from the occurence"
84 (setf (attribute-map occurence
) (make-hash-table)))
86 (defgeneric find-occurence
(name)
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
)))))
96 attribute
(description)
97 ((attribute-name :layered-accessor attribute.name
99 :initform
(gensym "ATTRIBUTE-")
101 (occurence :accessor occurence
:initarg
:occurence
:initform nil
)
102 (label :initarg
:label
:layered-accessor label
:initform nil
:special t
)))
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
))))
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."))
119 (define-layered-method label
:around
((attribute standard-attribute
))
120 (or (call-next-method) (attribute.name attribute
)))
122 (defmacro defattribute
(name supers slots
&rest args
)
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
)))
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
)
144 (:default-initargs
:properties
(list ,@properties
)
145 ,@ (cdr (assoc :default-initargs args
))))
149 (not (find-attribute-class-for-type name
)))
150 `(defmethod find-attribute-class-for-type ((type (eql ',type
)))
153 (defun clear-attributes (name)
154 "removes all attributes from an occurance"
155 (clear-occurence (find-occurence name
)))
157 (defmethod find-attribute-class-for-type (type)
160 (defun make-attribute (&rest args
&key type
&allow-other-keys
)
161 (apply #'make-instance
162 (or (find-attribute-class-for-type type
)
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
)))
172 (defmethod find-attribute ((occurence null
) name
)
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
180 (closer-mop:class-direct-superclasses
182 (when class-direct-superclasses
185 (find-occurence (class-name
187 class-direct-superclasses
)))
191 (defmethod find-all-attributes ((occurence standard-occurence
))
192 (loop for att being the hash-values of
(attribute-map occurence
)
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
)
201 ;;;; The following functions make up the public interface to the
202 ;;;; MEWA Attribute Occurence system.
204 (defmethod find-all-attributes (occurence-name)
205 (find-all-attributes (find-occurence occurence-name
)))
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
))
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
)))
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
))
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
))
228 (defmethod find-attribute ((attribute-with-occurence attribute
) attribute-name
)
229 (find-attribute (occurence attribute-with-occurence
) attribute-name
))
231 (defmethod set-attribute-properties ((occurence-name t
) attribute properties
)
232 (setf (description.properties attribute
) (plist-nunion
234 (description.properties attribute
)))
235 (loop for
(initarg value
) on
(description.properties attribute
)
237 with map
= (initargs.slot-names attribute
)
238 do
(let ((s-n (assoc-if #'(lambda (x) (member initarg x
)) map
)))
242 (setf (slot-value attribute
245 (warn "Cannot find initarg ~A in attribute ~S" initarg attribute
)))
246 finally
(return attribute
)))
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
)
260 (when att
(description.properties att
))))))))
262 (defmethod perform-define-attributes ((occurence-name t
) attributes
)
263 (loop for attribute in attributes
264 do
(destructuring-bind (name type
&rest args
)
266 (cond ((not (null type
))
267 ;;set the type as well
268 (set-attribute occurence-name name
(cons type args
)))))))
270 (defmacro define-attributes
(occurence-names &body attribute-definitions
)
272 ,@(loop for occurence-name in occurence-names
273 collect
`(perform-define-attributes (quote ,occurence-name
) (quote ,attribute-definitions
)))))
276 (defmethod find-description (object type
)
277 (let ((occurence (find-occurence object
)))
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
)))
288 #'(lambda (value object
)
289 (setf (slot-value object slot-name
) value
)))
291 #'(lambda (value object
)
292 (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute
))))))
295 (define-layered-function attribute-value
(instance attribute
)
296 (:documentation
" Like SLOT-VALUE for instances, the base method calls GETTER."))
298 (defmethod attribute-slot-value (instance attribute
)
299 "Return (VALUES slot-value-or-nil existsp boundp
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
)
305 ((and (slot-boundp attribute
'slot-name
) (slot-name attribute
))
306 (when (slot-exists-p instance
(slot-name attribute
))
308 (when (slot-boundp instance
(slot-name attribute
))
310 slot-value-or-nil
(slot-value
312 (slot-name attribute
))))))
313 ((and (slot-exists-p instance
(attribute.name attribute
)))
315 (when (slot-boundp instance
(attribute.name attribute
))
317 slot-value-or-nil
(slot-value
319 (attribute.name attribute
))))))
320 (VALUES slot-value-or-nil existsp boundp
)))
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
)
329 (funcall getter instance
)
330 ;;;; or default to the attribute-slot-value
331 (attribute-slot-value instance attribute
))))
333 (define-layered-function (setf attribute-value
) (value instance attribute
))
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
))
345 (error "Cannot set ~A in ~A" attribute instance
)))))
349 ;;;; ** Default Attributes
350 ;;;; TODO: This is mosty an ugly hack and should be reworked.
352 ;;;; The default mewa class contains the types use as defaults.
353 ;;;; maps meta-model slot-types to slot-presentation
355 (defvar *default-attributes-class-name
* 'default
)
357 (defmacro with-default-attributes
((occurence-name) &body body
)
358 `(let ((*default-attributes-class-name
* ',occurence-name
))
361 (define-attributes (default)
367 (clsql:generalized-boolean boolean
)
370 (defun attribute-to-definition (attribute)
371 (nconc (list (attribute.name attribute
)
372 (description.type attribute
))
373 (description.properties attribute
)))
375 (defun find-default-presentation-attribute-definitions ()
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
)))
384 (description.type possible-default
))
386 (description.type real-default
))
389 (defun gen-presentation-slots (instance)
390 (mapcar #'(lambda (x) (gen-pslot (cadr x
)
393 (meta-model:list-slot-types instance
)))
396 (defun gen-pslot (type label slot-name
)
397 (copy-list `(,(gen-ptype type
)
399 :slot-name
,slot-name
)))
401 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.