add support for lines to default display
[clinton/lisp-on-lines.git] / src / mewa.lisp
1 (declaim (optimize (speed 2) (space 3) (safety 0)))
2
3 (in-package :lisp-on-lines)
4
5 (defparameter *default-type* :ucw)
6
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)
22 (described-object
23 :layered-accessor object
24 :initform nil
25 :special t)
26 (description-attributes
27 :accessor attributes
28 :initarg :attributes
29 :initform nil
30 :special t)))
31
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))))
36
37 ;;;; * Occurences
38
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.")
43
44 (define-layered-class
45 standard-occurence (description)
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)
65 (:method (thing)
66 nil)
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)))))
71
72
73 (define-layered-class
74 attribute (description)
75 ((attribute-name :layered-accessor attribute.name
76 :initarg :name
77 :initform (gensym "ATTRIBUTE-")
78 :special t)
79 (occurence :accessor occurence :initarg :occurence :initform nil)
80 (label :initarg :label :layered-accessor label :initform nil :special t)))
81
82 ;;;; * Attributes
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))))
87
88 (define-layered-class
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."))
95
96 (defmacro defattribute (name supers slots &rest args)
97 (let* (
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)))
107 args
108 :key #'car)))
109
110 `(progn
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)
117 ,@cargs
118 (:default-initargs :properties (list ,@properties)
119 ,@ (cdr (assoc :default-initargs args))))
120
121 ,(unless (not type-provided-p)
122 `(defmethod find-attribute-class-for-type ((type (eql ',type)))
123 ',name)))))
124
125 (define-layered-class
126 display-attribute (attribute)
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
135 (defmethod find-attribute-class-for-type (type)
136 nil)
137
138 (defmethod find-attribute-class-for-name (name)
139 "presentation attributes are named using keywords"
140 (if (keywordp name)
141 'display-attribute
142 'standard-attribute))
143
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))
149
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))
155 attribute)))
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
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)
168 args))
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)
177 "Return the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name"
178 (find-attribute (find-occurence occurence-name) attribute-name))
179
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)))
184
185
186 (defmethod find-attribute ((attribute-with-occurence attribute) attribute-name)
187 (find-attribute (occurence attribute-with-occurence) attribute-name))
188
189 (defmethod set-attribute-properties ((occurence-name t) attribute properties)
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))))))))
219
220 (defmethod perform-define-attributes ((occurence-name t) attributes)
221 (loop for attribute in attributes
222 do (destructuring-bind (name type &rest args)
223 attribute
224 (cond ((not (null type))
225 ;;set the type as well
226 (set-attribute occurence-name name (cons type args)))))))
227
228 (defmacro define-attributes (occurence-names &body attribute-definitions)
229 `(progn
230 ,@(loop for occurence-name in occurence-names
231 collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions)))))
232
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)))
242
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)))
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)
254 (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute))))))
255
256
257 (define-layered-function attribute-value (instance attribute)
258 (:documentation " Like SLOT-VALUE for instances, the base method calls GETTER."))
259
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)))))))
270
271 (define-layered-function (setf attribute-value) (value instance attribute))
272
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)
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)))))
285
286
287
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
296 (defmacro with-default-attributes ((occurence-name) &body body)
297 `(let ((*default-attributes-class-name* ',occurence-name))
298 ,@body))
299
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)
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))
315
316 (defun find-presentation-attributes (occurence-name)
317 (loop for att in (find-all-attributes occurence-name)
318 when (typep att 'display-attribute)
319 collect att))
320
321 (defun attribute-to-definition (attribute)
322 (nconc (list (attribute.name attribute)
323 (description.type attribute))
324 (description.properties attribute)))
325
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*))))))
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)))
338 (cond
339 (possible-default
340 (description.type possible-default))
341 (real-default
342 (description.type real-default))
343 (t type))))
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
351
352 (defun gen-pslot (type label slot-name)
353 (copy-list `(,(gen-ptype type)
354 :label ,label
355 :slot-name ,slot-name)))
356
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.