1 (in-package :lisp-on-lines
)
3 (defun persistentp (object)
4 (slot-value object
'clsql-sys
::view-database
))
6 (define-layered-class description
()
9 :accessor description-type
14 :accessor description-layers
18 :layered-accessor object
21 (description-default-attributes
22 :accessor default-attributes
23 :initarg
:default-attributes
26 (description-attributes
31 (description-properties
32 :accessor description-properties
36 (description-default-properties
37 :accessor default-properties
38 :initarg
:default-properties
42 (defmethod attributes :around
((description description
))
43 "Add any default properties to the attributes"
45 (let ((default-properties (default-properties description
))) (if (and (listp default-properties
)
46 (not (null default-properties
)))
47 (let ((a (mapcar #'(lambda (att)
48 (append (ensure-list att
) default-properties
))
55 (defmethod print-object ((self description
) stream
)
56 (print-unreadable-object (self stream
:type t
)
57 (with-slots (description-type) self
58 (format stream
"~A" description-type
))))
62 (defvar *occurence-map
* (make-hash-table)
63 "a display is generated by associating an 'occurence'
64 with an instance of a class. This is usually keyed off class-name,
65 although an arbitrary occurence could be used with an arbitrary class.")
68 standard-occurence
(description)
69 ((occurence-name :accessor name
:initarg
:name
)
70 (attribute-map :accessor attribute-map
:initform
(make-hash-table)))
72 "an occurence holds the attributes like a class holds slot-definitions.
73 Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."))
75 (defun find-or-create-occurence (name)
76 "Returns the occurence associated with this name."
77 (or (get-occurence name
)
78 (values (setf (get-occurence name
) (make-instance 'standard-occurence
:name name
))
81 (defun get-occurence (name)
82 (gethash name
*occurence-map
*))
84 (defun (setf get-occurence
) (occurence name
)
85 (setf (gethash name
*occurence-map
*) occurence
))
87 (defun clear-occurence (occurence)
88 "removes all attributes from the occurence"
89 (setf (attribute-map occurence
) (make-hash-table)))
91 (defmethod make-attribute-using-slot-definition (slotd)
93 :name
(closer-mop:slot-definition-name slotd
)
94 :type-spec
(closer-mop:slot-definition-type slotd
)
95 :type
(first (remove-if (lambda (item)
100 (ensure-list (closer-mop:slot-definition-type slotd
))))))
102 (defmethod initialize-occurence-for-instance (occurence instance
)
103 (let ((slots (closer-mop:class-slots
(class-of instance
))))
105 (let ((att (make-attribute-using-slot-definition s
)))
106 (setf (find-attribute occurence
(attribute-name att
)) att
)))
109 (defgeneric find-occurence
(name)
112 (:method
((name symbol
))
113 (find-or-create-occurence name
))
114 (:method
((instance standard-object
))
115 (multiple-value-bind (occ new?
)
116 (find-or-create-occurence (class-name-of instance
))
118 (initialize-occurence-for-instance occ instance
)
121 (defun list-attributes (occurence)
123 (maphash (lambda (k v
)
126 (attribute-map occurence
))
130 (define-layered-class
131 attribute
(description)
132 ((attribute-name :layered-accessor attribute-name
134 :initform
(gensym "ATTRIBUTE-")
136 (occurence :accessor occurence
:initarg
:occurence
:initform nil
)
137 (label :initarg
:label
:layered-accessor label
:initform nil
:special t
)))
141 (defmethod print-object ((self attribute
) stream
)
142 (print-unreadable-object (self stream
:type t
)
143 (with-slots (attribute-name description-type
) self
144 (format stream
"~A ~A" description-type attribute-name
))))
146 (define-layered-class
147 standard-attribute
(attribute)
148 ((setter :accessor setter
:initarg
:setter
:special t
:initform nil
)
149 (getter :accessor getter
:initarg
:getter
:special t
:initform nil
)
150 (value :accessor value
:initarg
:value
:special t
)
151 (slot-name :accessor slot-name
:initarg
:slot-name
:special t
:initform nil
)
152 (typespec :accessor type-spec
:initarg
:type-spec
:initform nil
))
153 (: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."))
155 (define-layered-method label
:around
((attribute standard-attribute
))
156 (or (call-next-method) (attribute-name attribute
)))
158 (defmacro defattribute
(name supers slots
&rest args
)
160 (type-provided-p (second (assoc :type-name args
)))
161 (type (or type-provided-p name
))
162 (layer (or (second (assoc :in-layer args
)) nil
))
163 (properties (cdr (assoc :default-properties args
)))
164 (cargs (remove-if #'(lambda (key)
165 (or (eql key
:type-name
)
166 (eql key
:default-properties
)
167 (eql key
:default-initargs
)
168 (eql key
:in-layer
)))
173 (define-layered-class
174 ;;;; TODO: fix the naive way of making sure s-a is a superclass
175 ;;;; Need some MOPey goodness.
176 ,name
,@ (when layer
`(:in-layer
,layer
)),(or supers
'(standard-attribute))
177 ,(append slots
(properties-as-slots properties
))
178 #+ (or) ,@ (cdr cargs
)
180 (:default-initargs
:properties
(list ,@properties
)
181 ,@ (cdr (assoc :default-initargs args
))))
185 (not (find-attribute-class-for-type name
)))
186 `(defmethod find-attribute-class-for-type ((type (eql ',type
)))
189 (defun clear-attributes (name)
190 "removes all attributes from an occurance"
191 (clear-occurence (find-occurence name
)))
193 (defmethod find-attribute-class-for-type (type)
196 (defun make-attribute (&rest args
&key type
&allow-other-keys
)
197 (apply #'make-instance
198 (or (find-attribute-class-for-type type
)
203 (defmethod ensure-attribute ((occurence standard-occurence
) &rest args
&key name
&allow-other-keys
)
204 "Creates an attribute in the given occurence"
205 (let ((attribute (apply #'make-attribute
:occurence occurence args
)))
206 (setf (find-attribute occurence name
) attribute
)))
208 (defmethod find-attribute ((occurence null
) name
)
211 (defmethod find-attribute ((occurence standard-occurence
) name
)
212 (or (gethash name
(attribute-map occurence
))
213 (let* ((class (ignore-errors (find-class (name occurence
))))
214 (class-direct-superclasses
216 (closer-mop:class-direct-superclasses
218 (when class-direct-superclasses
221 (find-occurence (class-name
223 class-direct-superclasses
)))
227 (defmethod find-all-attributes ((occurence standard-occurence
))
228 (loop for att being the hash-values of
(attribute-map occurence
)
231 (defmethod ensure-attribute (occurence-name &rest args
&key name type
&allow-other-keys
)
232 (declare (ignore name type
))
233 (apply #'ensure-attribute
234 (find-occurence occurence-name
)
237 ;;;; The following functions make up the public interface to the
238 ;;;; MEWA Attribute Occurence system.
240 (defmethod find-all-attributes (occurence-name)
241 (find-all-attributes (find-occurence occurence-name
)))
243 (defmethod find-attribute (occurence-name attribute-name
)
244 "Return the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name"
245 (find-attribute (find-occurence occurence-name
) attribute-name
))
247 (defmethod (setf find-attribute
) ((attribute-spec list
) occurence-name attribute-name
)
248 "Create a new attribute in the occurence.
249 ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
250 (apply #'ensure-attribute occurence-name
:name attribute-name
:type
(first attribute-spec
) (rest attribute-spec
)))
252 (defmethod (setf find-attribute
) ((attribute standard-attribute
) occurence attribute-name
)
253 "Create a new attribute in the occurence.
254 ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
255 (setf (gethash attribute-name
(attribute-map occurence
))
258 (defmethod (setf find-attribute
) ((attribute null
) occurence attribute-name
)
259 "Create a new attribute in the occurence.
260 ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
261 (setf (gethash attribute-name
(attribute-map occurence
))
264 (defmethod find-attribute ((attribute-with-occurence attribute
) attribute-name
)
265 (find-attribute (occurence attribute-with-occurence
) attribute-name
))
267 (defmethod set-attribute-properties ((occurence-name t
) attribute properties
)
268 (setf (description-properties attribute
) (plist-nunion
270 (description-properties attribute
)))
271 (loop for
(initarg value
) on
(description-properties attribute
)
273 with map
= (initargs.slot-names attribute
)
274 do
(let ((s-n (assoc-if #'(lambda (x) (member initarg x
)) map
)))
278 (setf (slot-value attribute
281 (warn "Cannot find initarg ~A in attribute ~S" initarg attribute
)))
282 finally
(return attribute
)))
284 (defmethod set-attribute (occurence-name attribute-name attribute-spec
&key
(inherit t
))
285 "If inherit is T, sets the properties of the attribute only, unless the type has changed.
286 otherwise, (setf find-attribute)"
287 (let ((att (find-attribute occurence-name attribute-name
)))
288 (if (and att inherit
(or (eql (car attribute-spec
)
289 (description-type att
))
290 (eq (car attribute-spec
) t
)))
291 (set-attribute-properties occurence-name att
(cdr attribute-spec
))
292 (setf (find-attribute occurence-name attribute-name
)
293 (cons (car attribute-spec
)
296 (when att
(description-properties att
))))))))
298 (defmethod perform-define-attributes ((occurence-name t
) attributes
)
299 (loop for attribute in attributes
300 do
(destructuring-bind (name type
&rest args
)
302 (cond ((not (null type
))
303 ;;set the type as well
304 (set-attribute occurence-name name
(cons type args
)))))))
306 (defmacro define-attributes
(occurence-names &body attribute-definitions
)
308 ,@(loop for occurence-name in occurence-names
309 collect
`(perform-define-attributes (quote ,occurence-name
) (quote ,attribute-definitions
)))))
312 (defmethod find-description (object type
)
313 (let ((occurence (find-occurence object
)))
317 (defmethod setter (attribute)
318 (warn "Setting ~A in ~A" attribute
*context
*)
319 (let ((setter (getf (description-properties attribute
) :setter
))
320 (slot-name (getf (description-properties attribute
) :slot-name
)))
324 #'(lambda (value object
)
325 (setf (slot-value object slot-name
) value
)))
327 #'(lambda (value object
)
328 (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute
))))))
331 (define-layered-function attribute-value
(instance attribute
)
332 (:documentation
" Like SLOT-VALUE for instances, the base method calls GETTER."))
334 (defmethod attribute-slot-value (instance attribute
)
335 "Return (VALUES slot-value-or-nil existsp boundp
337 If this attribute, in its current context, refers to a slot,
338 we return slot-value-or nil either boundp or not."
339 (let (existsp boundp slot-value-or-nil
)
341 ((and (slot-boundp attribute
'slot-name
) (slot-name attribute
))
342 (when (slot-exists-p instance
(slot-name attribute
))
344 (when (slot-boundp instance
(slot-name attribute
))
346 slot-value-or-nil
(slot-value
348 (slot-name attribute
))))))
349 ((and (slot-exists-p instance
(attribute-name attribute
)))
351 (when (slot-boundp instance
(attribute-name attribute
))
353 slot-value-or-nil
(slot-value
355 (attribute-name attribute
))))))
356 (VALUES slot-value-or-nil existsp boundp
)))
358 (define-layered-method attribute-value
(instance (attribute standard-attribute
))
359 "return the attribute value or NIL if it cannot be found"
360 (with-slots (getter value
) attribute
361 (when (slot-boundp attribute
'value
)
362 (setf getter
(constantly value
)))
363 (if (and (slot-boundp attribute
'getter
) getter
)
365 (funcall getter instance
)
366 ;;;; or default to the attribute-slot-value
367 (attribute-slot-value instance attribute
))))
369 (define-layered-function (setf attribute-value
) (value instance attribute
))
371 (define-layered-method
372 (setf attribute-value
) (value instance
(attribute standard-attribute
))
373 (with-slots (setter slot-name
) attribute
374 (cond ((and (slot-boundp attribute
'setter
) setter
)
375 (funcall setter value instance
))
376 ((and (slot-boundp attribute
'slot-name
) slot-name
)
377 (setf (slot-value instance slot-name
) value
))
378 ((and (slot-exists-p instance
(attribute-name attribute
)))
379 (setf (slot-value instance
(attribute-name attribute
)) value
))
381 (error "Cannot set ~A in ~A" attribute instance
)))))
385 ;;;; ** Default Attributes
386 ;;;; TODO: This is mosty an ugly hack and should be reworked.
388 ;;;; The default mewa class contains the types use as defaults.
389 ;;;; maps meta-model slot-types to slot-presentation
391 (defvar *default-attributes-class-name
* 'default
)
393 (defmacro with-default-attributes
((occurence-name) &body body
)
394 `(let ((*default-attributes-class-name
* ',occurence-name
))
397 (define-attributes (default)
403 (clsql:generalized-boolean boolean
)
406 (defun attribute-to-definition (attribute)
407 (nconc (list (attribute-name attribute
)
408 (description-type attribute
))
409 (description-properties attribute
)))
411 (defun find-default-presentation-attribute-definitions ()
414 (defun gen-ptype (type)
415 (let* ((type (if (consp type
) (car type
) type
))
416 (possible-default (find-attribute *default-attributes-class-name
* type
))
417 (real-default (find-attribute 'default type
)))
420 (description-type possible-default
))
422 (description-type real-default
))
425 (defun gen-presentation-slots (instance)
426 (mapcar #'(lambda (x) (gen-pslot (cadr x
)
429 (meta-model:list-slot-types instance
)))
432 (defun gen-pslot (type label slot-name
)
433 (copy-list `(,(gen-ptype type
)
435 :slot-name
,slot-name
)))
437 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.