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-attributes
32 (defmethod print-object ((self description
) stream
)
33 (print-unreadable-object (self stream
:type t
)
34 (with-slots (description-type) self
35 (format t
"~A" description-type
))))
39 (defvar *occurence-map
* (make-hash-table)
40 "a display is generated by associating an 'occurence'
41 with an instance of a class. This is usually keyed off class-name,
42 although an arbitrary occurence can be used with an arbitrary class.")
45 standard-occurence
(description)
46 ((attribute-map :accessor attribute-map
:initform
(make-hash-table)))
48 "an occurence holds the attributes like a class holds slot-definitions.
49 Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."))
51 (defun find-or-create-occurence (name)
52 "Returns the occurence associated with this name."
53 (let ((occurence (gethash name
*occurence-map
*)))
56 (let ((new-occurence (make-instance 'standard-occurence
)))
57 (setf (gethash name
*occurence-map
*) new-occurence
)
60 (defun clear-occurence (occurence)
61 "removes all attributes from the occurence"
62 (setf (attribute-map occurence
) (make-hash-table)))
64 (defgeneric find-occurence
(name)
67 (:method
((name symbol
))
68 (find-or-create-occurence name
))
69 (:method
((instance standard-object
))
70 (find-or-create-occurence (class-name (class-of instance
)))))
74 attribute
(description)
75 ((attribute-name :layered-accessor attribute.name
77 :initform
(gensym "ATTRIBUTE-")
79 (occurence :accessor occurence
:initarg
:occurence
:initform nil
)
80 (label :initarg
:label
:layered-accessor label
:initform nil
:special t
)))
83 (defmethod print-object ((self attribute
) stream
)
84 (print-unreadable-object (self stream
:type t
)
85 (with-slots (name description-type
) self
86 (format stream
"~A ~A" description-type name
))))
89 standard-attribute
(attribute)
90 ((setter :accessor setter
:initarg
:setter
:special t
:initform nil
)
91 (getter :accessor getter
:initarg
:getter
:special t
:initform nil
)
92 (slot-name :accessor slot-name
:initarg
:slot-name
:special t
)
93 (id :accessor id
:initarg
:id
:special t
:initform
(random-string)))
94 (: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."))
96 (defmacro defattribute
(name supers slots
&rest args
)
98 (type-provided-p (second (assoc :type-name args
)))
99 (type (or type-provided-p name
))
100 (layer (or (second (assoc :in-layer args
)) nil
))
101 (properties (cdr (assoc :default-properties args
)))
102 (cargs (remove-if #'(lambda (key)
103 (or (eql key
:type-name
)
104 (eql key
:default-properties
)
105 (eql key
:default-initargs
)
106 (eql key
:in-layer
)))
111 (define-layered-class
112 ;;;; TODO: fix the naive way of making sure s-a is a superclass
113 ;;;; Need some MOPey goodness.
114 ,name
,@ (when layer
`(:in-layer
,layer
)),(or supers
'(standard-attribute))
115 ,(append slots
(properties-as-slots properties
))
116 #+ (or) ,@ (cdr cargs
)
118 (:default-initargs
:properties
(list ,@properties
)
119 ,@ (cdr (assoc :default-initargs args
))))
121 ,(unless (not type-provided-p
)
122 `(defmethod find-attribute-class-for-type ((type (eql ',type
)))
125 (define-layered-class
126 display-attribute
(attribute)
128 (:documentation
"Presentation Attributes are used to display objects
129 using the attributes defined in an occurence. Presentation Attributes are always named using keywords."))
131 (defun clear-attributes (name)
132 "removes all attributes from an occurance"
133 (clear-occurence (find-occurence name
)))
135 (defmethod find-attribute-class-for-type (type)
138 (defmethod find-attribute-class-for-name (name)
139 "presentation attributes are named using keywords"
142 'standard-attribute
))
144 (defun make-attribute (&rest args
&key name type
&allow-other-keys
)
145 (apply #'make-instance
146 (or (find-attribute-class-for-type type
)
147 (find-attribute-class-for-name name
))
150 (defmethod ensure-attribute ((occurence standard-occurence
) &rest args
&key name
&allow-other-keys
)
151 "Creates an attribute in the given occurence"
152 (let ((attribute (apply #'make-attribute
:occurence occurence args
)))
153 (setf (description.properties attribute
) args
)
154 (setf (gethash name
(attribute-map occurence
))
157 (defmethod find-attribute ((occurence standard-occurence
) name
)
158 (gethash name
(attribute-map occurence
)))
160 (defmethod find-all-attributes ((occurence standard-occurence
))
161 (loop for att being the hash-values of
(attribute-map occurence
)
164 (defmethod ensure-attribute (occurence-name &rest args
&key name type
&allow-other-keys
)
165 (declare (ignore name type
))
166 (apply #'ensure-attribute
167 (find-occurence occurence-name
)
170 ;;;; The following functions make up the public interface to the
171 ;;;; MEWA Attribute Occurence system.
173 (defmethod find-all-attributes (occurence-name)
174 (find-all-attributes (find-occurence occurence-name
)))
176 (defmethod find-attribute (occurence-name attribute-name
)
177 "Return the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name"
178 (find-attribute (find-occurence occurence-name
) attribute-name
))
180 (defmethod (setf find-attribute
) ((attribute-spec list
) occurence-name attribute-name
)
181 "Create a new attribute in the occurence.
182 ATTRIBUTE-SPEC: a list of (type name &rest initargs)"
183 (apply #'ensure-attribute occurence-name
:name attribute-name
:type
(first attribute-spec
) (rest attribute-spec
)))
186 (defmethod find-attribute ((attribute-with-occurence attribute
) attribute-name
)
187 (find-attribute (occurence attribute-with-occurence
) attribute-name
))
189 (defmethod set-attribute-properties ((occurence-name t
) attribute properties
)
190 (setf (description.properties attribute
) (plist-nunion
192 (description.properties attribute
)))
193 (loop for
(initarg value
) on
(description.properties attribute
)
195 with map
= (initargs.slot-names attribute
)
196 do
(let ((s-n (assoc-if #'(lambda (x) (member initarg x
)) map
)))
200 (setf (slot-value attribute
203 (warn "Cannot find initarg ~A in attribute ~S" initarg attribute
)))
204 finally
(return attribute
)))
206 (defmethod set-attribute (occurence-name attribute-name attribute-spec
&key
(inherit t
))
207 "If inherit is T, sets the properties of the attribute only, unless the type has changed.
208 otherwise, (setf find-attribute)"
209 (let ((att (find-attribute occurence-name attribute-name
)))
210 (if (and att inherit
(or (eql (car attribute-spec
)
211 (description.type att
))
212 (eq (car attribute-spec
) t
)))
213 (set-attribute-properties occurence-name att
(cdr attribute-spec
))
214 (setf (find-attribute occurence-name attribute-name
)
215 (cons (car attribute-spec
)
218 (when att
(description.properties att
))))))))
220 (defmethod perform-define-attributes ((occurence-name t
) attributes
)
221 (loop for attribute in attributes
222 do
(destructuring-bind (name type
&rest args
)
224 (cond ((not (null type
))
225 ;;set the type as well
226 (set-attribute occurence-name name
(cons type args
)))))))
228 (defmacro define-attributes
(occurence-names &body attribute-definitions
)
230 ,@(loop for occurence-name in occurence-names
231 collect
`(perform-define-attributes (quote ,occurence-name
) (quote ,attribute-definitions
)))))
233 (defmethod find-display-attribute (occurence name
)
234 (find-attribute occurence
(intern (symbol-name name
) "KEYWORD")))
236 (defmethod find-description (object type
)
237 (let ((occurence (find-occurence object
)))
238 (or (find-display-attribute
243 (defmethod setter (attribute)
244 (warn "Setting ~A in ~A" attribute
*context
*)
245 (let ((setter (getf (description.properties attribute
) :setter
))
246 (slot-name (getf (description.properties attribute
) :slot-name
)))
250 #'(lambda (value object
)
251 (setf (slot-value object slot-name
) value
)))
253 #'(lambda (value object
)
254 (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute
))))))
257 (define-layered-function attribute-value
(instance attribute
)
258 (:documentation
" Like SLOT-VALUE for instances, the base method calls GETTER."))
260 (define-layered-method attribute-value
(instance (attribute standard-attribute
))
261 (with-slots (getter slot-name
) attribute
262 (cond ((and (slot-boundp attribute
'getter
) getter
)
263 (funcall getter instance
))
264 ((and (slot-boundp attribute
'slot-name
) slot-name
)
265 (when (slot-boundp instance slot-name
)
266 (slot-value instance slot-name
)))
267 ((and (slot-exists-p instance
(attribute.name attribute
)) )
268 (when (slot-boundp instance
(attribute.name attribute
))
269 (slot-value instance
(attribute.name attribute
)))))))
271 (define-layered-function (setf attribute-value
) (value instance attribute
))
273 (define-layered-method
274 (setf attribute-value
) (value instance
(attribute standard-attribute
))
275 (with-slots (setter slot-name
) attribute
276 (cond ((and (slot-boundp attribute
'setter
) setter
)
278 (funcall setter value instance
))
279 ((and (slot-boundp attribute
'slot-name
) slot-name
)
280 (setf (slot-value instance slot-name
) value
))
281 ((and (slot-exists-p instance
(attribute.name attribute
)) slot-name
)
282 (setf (slot-value instance
(attribute.name attribute
)) value
))
284 (error "Cannot set ~A in ~A" attribute instance
)))))
288 ;;;; ** Default Attributes
291 ;;;; The default mewa class contains the types use as defaults.
292 ;;;; maps meta-model slot-types to slot-presentation
294 (defvar *default-attributes-class-name
* 'default
)
296 (defmacro with-default-attributes
((occurence-name) &body body
)
297 `(let ((*default-attributes-class-name
* ',occurence-name
))
300 (define-attributes (default)
301 (boolean mewa-boolean
)
303 (number mewa-currency
)
304 (integer mewa-integer
)
305 (currency mewa-currency
)
306 (clsql:generalized-boolean mewa-boolean
)
307 (foreign-key foreign-key
)
308 (:viewer mewa-viewer
)
309 (:editor mewa-editor
)
310 (:creator mewa-creator
)
311 (:as-string mewa-one-line-presentation
)
312 (:one-line mewa-one-line-presentation
)
313 (:listing mewa-list-presentation
:global-properties
(:editablep nil
) :editablep t
)
314 (:search-model mewa-object-presentation
))
316 (defun find-presentation-attributes (occurence-name)
317 (loop for att in
(find-all-attributes occurence-name
)
318 when
(typep att
'display-attribute
)
321 (defun attribute-to-definition (attribute)
322 (nconc (list (attribute.name attribute
)
323 (description.type attribute
))
324 (description.properties attribute
)))
326 (defun find-default-presentation-attribute-definitions ()
327 (if (eql *default-attributes-class-name
* 'default
)
328 (mapcar #'attribute-to-definition
(find-presentation-attributes 'default
))
329 (remove-duplicates (mapcar #'attribute-to-definition
331 (find-presentation-attributes 'default
)
332 (find-presentation-attributes
333 *default-attributes-class-name
*))))))
334 (defun gen-ptype (type)
335 (let* ((type (if (consp type
) (car type
) type
))
336 (possible-default (find-attribute *default-attributes-class-name
* type
))
337 (real-default (find-attribute 'default type
)))
340 (description.type possible-default
))
342 (description.type real-default
))
345 (defun gen-presentation-slots (instance)
346 (mapcar #'(lambda (x) (gen-pslot (cadr x
)
349 (meta-model:list-slot-types instance
)))
352 (defun gen-pslot (type label slot-name
)
353 (copy-list `(,(gen-ptype type
)
355 :slot-name
,slot-name
)))
357 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
358 ;; You are granted the rights to distribute
359 ;; and use this software as governed by the terms
360 ;; of the Lisp Lesser GNU Public License
361 ;; (http://opensource.franz.com/preamble.html),
362 ;; known as the LLGPL.