Commit | Line | Data |
---|---|---|
13ebe12f DC |
1 | (declaim (optimize (speed 2) (space 3) (safety 0))) |
2 | ||
5dea194e | 3 | (in-package :lisp-on-lines) |
13ebe12f | 4 | |
579597e3 | 5 | (defparameter *default-type* :ucw) |
6 | ||
2b0fd9c8 DC |
7 | (define-layered-class description () |
8 | ((description-type | |
9 | :initarg :type | |
10 | :accessor description.type | |
11 | :initform 'viewer | |
12 | :special t) | |
13 | (description-layers | |
14 | :initarg :layers | |
15 | :accessor description.layers | |
16 | :initform nil | |
17 | :special t) | |
18 | (description-properties | |
19 | :accessor description.properties | |
20 | :initform nil | |
21 | :special t) | |
0386c736 | 22 | (described-object |
23 | :layered-accessor object | |
24 | :initform nil | |
25 | :special t) | |
2b0fd9c8 DC |
26 | (description-attributes |
27 | :accessor attributes | |
28 | :initarg :attributes | |
29 | :initform nil | |
30 | :special t))) | |
579597e3 | 31 | |
2b0fd9c8 DC |
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)))) | |
579597e3 | 36 | |
15bc66bd DC |
37 | ;;;; * Occurences |
38 | ||
39 | (defvar *occurence-map* (make-hash-table) | |
2b0fd9c8 | 40 | "a display is generated by associating an 'occurence' |
15bc66bd DC |
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.") | |
43 | ||
44 | (define-layered-class | |
2b0fd9c8 | 45 | standard-occurence (description) |
15bc66bd DC |
46 | ((attribute-map :accessor attribute-map :initform (make-hash-table))) |
47 | (:documentation | |
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.")) | |
50 | ||
51 | (defun find-or-create-occurence (name) | |
52 | "Returns the occurence associated with this name." | |
53 | (let ((occurence (gethash name *occurence-map*))) | |
54 | (if occurence | |
55 | occurence | |
56 | (let ((new-occurence (make-instance 'standard-occurence))) | |
57 | (setf (gethash name *occurence-map*) new-occurence) | |
58 | new-occurence)))) | |
59 | ||
60 | (defun clear-occurence (occurence) | |
61 | "removes all attributes from the occurence" | |
62 | (setf (attribute-map occurence) (make-hash-table))) | |
63 | ||
64 | (defgeneric find-occurence (name) | |
bf12489a DC |
65 | (:method (thing) |
66 | nil) | |
15bc66bd DC |
67 | (:method ((name symbol)) |
68 | (find-or-create-occurence name)) | |
bf12489a | 69 | (:method ((instance standard-object)) |
15bc66bd DC |
70 | (find-or-create-occurence (class-name (class-of instance))))) |
71 | ||
72 | ||
2b0fd9c8 DC |
73 | (define-layered-class |
74 | attribute (description) | |
0386c736 | 75 | ((attribute-name :layered-accessor attribute.name |
2b0fd9c8 DC |
76 | :initarg :name |
77 | :initform (gensym "ATTRIBUTE-") | |
78 | :special t) | |
79 | (occurence :accessor occurence :initarg :occurence :initform nil) | |
0386c736 | 80 | (label :initarg :label :layered-accessor label :initform nil :special t))) |
2b0fd9c8 | 81 | |
15bc66bd | 82 | ;;;; * Attributes |
2b0fd9c8 DC |
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)))) | |
15bc66bd DC |
87 | |
88 | (define-layered-class | |
2b0fd9c8 DC |
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))) | |
15bc66bd DC |
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.")) |
95 | ||
6f63d3a4 | 96 | (defmacro defattribute (name supers slots &rest args) |
0386c736 | 97 | (let* ( |
98 | (type-provided-p (second (assoc :type-name args))) | |
99 | (type (or type-provided-p name)) | |
2b0fd9c8 DC |
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))) | |
107 | args | |
108 | :key #'car))) | |
109 | ||
6f63d3a4 | 110 | `(progn |
6f63d3a4 | 111 | (define-layered-class |
91f2ab7b | 112 | ;;;; TODO: fix the naive way of making sure s-a is a superclass |
2b0fd9c8 DC |
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) | |
117 | ,@cargs | |
118 | (:default-initargs :properties (list ,@properties) | |
119 | ,@ (cdr (assoc :default-initargs args)))) | |
120 | ||
0386c736 | 121 | ,(unless (not type-provided-p) |
122 | `(defmethod find-attribute-class-for-type ((type (eql ',type))) | |
123 | ',name))))) | |
15bc66bd | 124 | |
15bc66bd | 125 | (define-layered-class |
2b0fd9c8 | 126 | display-attribute (attribute) |
15bc66bd DC |
127 | () |
128 | (:documentation "Presentation Attributes are used to display objects | |
129 | using the attributes defined in an occurence. Presentation Attributes are always named using keywords.")) | |
130 | ||
131 | (defun clear-attributes (name) | |
132 | "removes all attributes from an occurance" | |
133 | (clear-occurence (find-occurence name))) | |
134 | ||
6f63d3a4 DC |
135 | (defmethod find-attribute-class-for-type (type) |
136 | nil) | |
137 | ||
15bc66bd DC |
138 | (defmethod find-attribute-class-for-name (name) |
139 | "presentation attributes are named using keywords" | |
140 | (if (keywordp name) | |
2b0fd9c8 | 141 | 'display-attribute |
15bc66bd DC |
142 | 'standard-attribute)) |
143 | ||
2b0fd9c8 DC |
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)) | |
148 | args)) | |
6f63d3a4 | 149 | |
2b0fd9c8 | 150 | (defmethod ensure-attribute ((occurence standard-occurence) &rest args &key name &allow-other-keys) |
15bc66bd | 151 | "Creates an attribute in the given occurence" |
2b0fd9c8 DC |
152 | (let ((attribute (apply #'make-attribute :occurence occurence args))) |
153 | (setf (description.properties attribute) args) | |
154 | (setf (gethash name (attribute-map occurence)) | |
155 | attribute))) | |
15bc66bd DC |
156 | |
157 | (defmethod find-attribute ((occurence standard-occurence) name) | |
158 | (gethash name (attribute-map occurence))) | |
159 | ||
160 | (defmethod find-all-attributes ((occurence standard-occurence)) | |
161 | (loop for att being the hash-values of (attribute-map occurence) | |
162 | collect att)) | |
163 | ||
2b0fd9c8 DC |
164 | (defmethod ensure-attribute (occurence-name &rest args &key name type &allow-other-keys) |
165 | (declare (ignore name type)) | |
166 | (apply #'ensure-attribute | |
15bc66bd | 167 | (find-occurence occurence-name) |
2b0fd9c8 | 168 | args)) |
15bc66bd DC |
169 | |
170 | ;;;; The following functions make up the public interface to the | |
171 | ;;;; MEWA Attribute Occurence system. | |
172 | ||
173 | (defmethod find-all-attributes (occurence-name) | |
174 | (find-all-attributes (find-occurence occurence-name))) | |
175 | ||
176 | (defmethod find-attribute (occurence-name attribute-name) | |
2b0fd9c8 | 177 | "Return the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name" |
15bc66bd DC |
178 | (find-attribute (find-occurence occurence-name) attribute-name)) |
179 | ||
2b0fd9c8 DC |
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))) | |
15bc66bd | 184 | |
2b0fd9c8 DC |
185 | |
186 | (defmethod find-attribute ((attribute-with-occurence attribute) attribute-name) | |
187 | (find-attribute (occurence attribute-with-occurence) attribute-name)) | |
579597e3 | 188 | |
15bc66bd | 189 | (defmethod set-attribute-properties ((occurence-name t) attribute properties) |
2b0fd9c8 DC |
190 | (setf (description.properties attribute) (plist-nunion |
191 | properties | |
192 | (description.properties attribute))) | |
193 | (loop for (initarg value) on (description.properties attribute) | |
194 | by #'cddr | |
195 | with map = (initargs.slot-names attribute) | |
196 | do (let ((s-n (assoc-if #'(lambda (x) (member initarg x)) map))) | |
197 | ||
198 | (if s-n | |
199 | (progn | |
200 | (setf (slot-value attribute | |
201 | (cdr s-n)) | |
202 | value)) | |
203 | (warn "Cannot find initarg ~A in attribute ~S" initarg attribute))) | |
204 | finally (return attribute))) | |
205 | ||
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) | |
216 | (plist-nunion | |
217 | (cdr attribute-spec) | |
218 | (when att (description.properties att)))))))) | |
fc3e754f | 219 | |
15bc66bd | 220 | (defmethod perform-define-attributes ((occurence-name t) attributes) |
fc3e754f DC |
221 | (loop for attribute in attributes |
222 | do (destructuring-bind (name type &rest args) | |
223 | attribute | |
2b0fd9c8 DC |
224 | (cond ((not (null type)) |
225 | ;;set the type as well | |
226 | (set-attribute occurence-name name (cons type args))))))) | |
fc3e754f | 227 | |
15bc66bd | 228 | (defmacro define-attributes (occurence-names &body attribute-definitions) |
fc3e754f | 229 | `(progn |
15bc66bd DC |
230 | ,@(loop for occurence-name in occurence-names |
231 | collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions))))) | |
232 | ||
2b0fd9c8 DC |
233 | (defmethod find-display-attribute (occurence name) |
234 | (find-attribute occurence (intern (symbol-name name) "KEYWORD"))) | |
235 | ||
236 | (defmethod find-description (object type) | |
237 | (let ((occurence (find-occurence object))) | |
238 | (or (find-display-attribute | |
239 | occurence | |
240 | type) | |
241 | occurence))) | |
15bc66bd DC |
242 | |
243 | (defmethod setter (attribute) | |
6f63d3a4 | 244 | (warn "Setting ~A in ~A" attribute *context*) |
2b0fd9c8 DC |
245 | (let ((setter (getf (description.properties attribute) :setter)) |
246 | (slot-name (getf (description.properties attribute) :slot-name))) | |
15bc66bd DC |
247 | (cond (setter |
248 | setter) | |
249 | (slot-name | |
250 | #'(lambda (value object) | |
251 | (setf (slot-value object slot-name) value))) | |
252 | (t | |
253 | #'(lambda (value object) | |
2b0fd9c8 | 254 | (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute)))))) |
15bc66bd | 255 | |
d5e996b3 | 256 | |
6f63d3a4 DC |
257 | (define-layered-function attribute-value (instance attribute) |
258 | (:documentation " Like SLOT-VALUE for instances, the base method calls GETTER.")) | |
259 | ||
6f63d3a4 | 260 | (define-layered-method attribute-value (instance (attribute standard-attribute)) |
2b0fd9c8 DC |
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))))))) | |
6f63d3a4 | 270 | |
a4e6154d | 271 | (define-layered-function (setf attribute-value) (value instance attribute)) |
6f63d3a4 | 272 | |
2b0fd9c8 DC |
273 | (define-layered-method |
274 | (setf attribute-value) (value instance (attribute standard-attribute)) | |
2b0fd9c8 DC |
275 | (with-slots (setter slot-name) attribute |
276 | (cond ((and (slot-boundp attribute 'setter) setter) | |
277 | ||
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)) | |
283 | (t | |
284 | (error "Cannot set ~A in ~A" attribute instance))))) | |
d5e996b3 DC |
285 | |
286 | ||
a4e6154d | 287 | |
d5e996b3 DC |
288 | ;;;; ** Default Attributes |
289 | ||
290 | ||
291 | ;;;; The default mewa class contains the types use as defaults. | |
292 | ;;;; maps meta-model slot-types to slot-presentation | |
293 | ||
294 | (defvar *default-attributes-class-name* 'default) | |
295 | ||
15bc66bd DC |
296 | (defmacro with-default-attributes ((occurence-name) &body body) |
297 | `(let ((*default-attributes-class-name* ',occurence-name)) | |
298 | ,@body)) | |
299 | ||
d5e996b3 DC |
300 | (define-attributes (default) |
301 | (boolean mewa-boolean) | |
302 | (string mewa-string) | |
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) | |
63c06c54 | 311 | (:as-string mewa-one-line-presentation) |
d5e996b3 DC |
312 | (:one-line mewa-one-line-presentation) |
313 | (:listing mewa-list-presentation :global-properties (:editablep nil) :editablep t) | |
314 | (:search-model mewa-object-presentation)) | |
315 | ||
15bc66bd DC |
316 | (defun find-presentation-attributes (occurence-name) |
317 | (loop for att in (find-all-attributes occurence-name) | |
2b0fd9c8 | 318 | when (typep att 'display-attribute) |
15bc66bd | 319 | collect att)) |
d5e996b3 | 320 | |
15bc66bd DC |
321 | (defun attribute-to-definition (attribute) |
322 | (nconc (list (attribute.name attribute) | |
2b0fd9c8 DC |
323 | (description.type attribute)) |
324 | (description.properties attribute))) | |
d5e996b3 | 325 | |
15bc66bd DC |
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 | |
330 | (append | |
331 | (find-presentation-attributes 'default) | |
332 | (find-presentation-attributes | |
333 | *default-attributes-class-name*)))))) | |
d5e996b3 | 334 | (defun gen-ptype (type) |
15bc66bd DC |
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))) | |
338 | (cond | |
339 | (possible-default | |
2b0fd9c8 | 340 | (description.type possible-default)) |
15bc66bd | 341 | (real-default |
2b0fd9c8 | 342 | (description.type real-default)) |
15bc66bd | 343 | (t type)))) |
d5e996b3 DC |
344 | |
345 | (defun gen-presentation-slots (instance) | |
346 | (mapcar #'(lambda (x) (gen-pslot (cadr x) | |
347 | (string (car x)) | |
348 | (car x))) | |
349 | (meta-model:list-slot-types instance))) | |
350 | ||
34e8e2d6 | 351 | |
d5e996b3 DC |
352 | (defun gen-pslot (type label slot-name) |
353 | (copy-list `(,(gen-ptype type) | |
354 | :label ,label | |
355 | :slot-name ,slot-name))) | |
356 | ||
233380f7 | 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. |