added define-attributes macro
[clinton/lisp-on-lines.git] / src / mewa / mewa.lisp
1 (in-package :mewa)
2
3 (defparameter *default-type* :ucw)
4
5 ;;; maps meta-model slot-types to slot-presentation
6 (defparameter *slot-type-map*
7 '(boolean mewa-boolean
8 string mewa-string
9 number mewa-currency
10 integer mewa-integer
11 currency mewa-currency
12 clsql:generalized-boolean mewa-boolean))
13
14 ;;; an alist of model-class-name . attributes
15 ;;; should really be a hash-table.
16 (defvar *attribute-map* (list))
17
18 ;;; some utilities for merging plists
19
20 (defun plist-nunion (new-props plist)
21 (loop for cons on new-props by #'cddr
22 do (setf (getf plist (first cons)) (second cons))
23 finally (return plist)))
24
25 (defun plist-union (new-props plist)
26 "Non-destructive version of plist-nunion"
27 (plist-nunion new-props (copy-list plist)))
28
29 (defun gen-ptype (type)
30 (or (getf *slot-type-map* type) type))
31
32 (defun gen-presentation-slots (instance)
33 (mapcar #'(lambda (x) (gen-pslot (cadr x)
34 (string (car x))
35 (car x)))
36 (meta-model:list-slot-types instance)))
37
38
39 (defun gen-pslot (type label slot-name)
40 (copy-list `(,(gen-ptype type)
41 :label ,label
42 :slot-name ,slot-name)))
43
44 (defun gen-presentation-args (instance args)
45 (declare (ignore instance))
46 (if args args nil))
47
48
49 (defun find-or-create-attributes (class-name)
50 "return an exisiting class attribute map or create one.
51
52 A map is a cons of class-name . attributes.
53 attributes is an alist keyed on the attribute name."
54 (or (assoc class-name *attribute-map*)
55 (progn
56 (setf *attribute-map* (acons class-name (list (list)) *attribute-map*))
57 (assoc class-name *attribute-map*))))
58
59 (defgeneric find-class-attributes (class))
60
61 (defmethod find-class-attributes ((model t))
62 (find-or-create-attributes (class-name (class-of model))))
63
64 (defmethod find-class-attributes ((model symbol))
65 (find-or-create-attributes model))
66
67 (defmethod clear-class-attributes ((model t))
68 (setf (cdr (find-class-attributes model)) nil))
69
70 (defmethod add-attribute ((model t) name def)
71 (let ((map (find-class-attributes model)))
72 (setf (cdr map) (acons name def (cdr map)))))
73
74 (defmethod find-attribute ((model t) name)
75 (assoc name (cdr (find-class-attributes model))))
76
77 (defmethod (setf find-attribute) ((def list) (model t) name)
78 (let ((attr (find-attribute model name)))
79 (if attr
80 (prog2
81 (setf (cdr attr) def)
82 attr)
83 (prog2
84 (add-attribute model name def)
85 (find-attribute model name)))))
86
87 (defmethod set-attribute ((model t) name definition &key (inherit t))
88 (setf (find-attribute model name)
89 (if inherit
90 (cons (car definition)
91 (plist-union (cdr definition)
92 (cddr (find-attribute model name))))
93 definition)))
94
95 (defmethod perform-set-attributes ((model t) definitions)
96 (dolist (def definitions)
97 (funcall #'set-attribute model (first def) (rest def))))
98
99 (defmethod set-attribute-properties ((model t) attribute properties)
100 (let ((a (find-attribute model attribute)))
101 (if a
102 (setf (cddr a) (plist-nunion properties (cddr a)))
103 (error "Attribute ~A does not exist" attribute) )))
104
105 (defmethod perform-set-attribute-properties ((model t) definitions)
106 (dolist (def definitions)
107 (funcall #'set-attribute-properties model (car def) (cdr def))))
108
109 (defmethod perform-define-attributes ((model t) attributes)
110 (loop for attribute in attributes
111 do (destructuring-bind (name type &rest args)
112 attribute
113 (cond ((eq type t)
114 ;;use the existing (default) type
115 (set-attribute-properties model name args))
116 ((not (null type))
117 ;;set the type as well
118 (set-attribute model name (cons type args)))))))
119
120 (defmacro define-attributes (models &body attribute-definitions)
121 `(progn
122 ,@(loop for model in models
123 collect `(perform-define-attributes (quote ,model) (quote ,attribute-definitions)))
124 (mapcar #'find-class-attributes (quote ,models ))))
125
126
127 (defmethod default-attributes ((model t))
128 "return the default attributes for a given model using the meta-model's meta-data"
129 (append (mapcar #'(lambda (s)
130 (cons (car s)
131 (gen-pslot
132 (if (meta-model:foreign-key-p model (car s))
133 'foreign-key
134 (cadr s))
135 (string (car s)) (car s))))
136 (meta-model:list-slot-types model))
137 (mapcar #'(lambda (s)
138 (cons s (append (gen-pslot 'has-many (string s) s)
139 `(:presentation
140 (make-presentation
141 ,model
142 :type :one-line)))))
143 (meta-model:list-has-many model))))
144
145 (defmethod set-default-attributes ((model t))
146 "Set the default attributes for MODEL"
147 (clear-class-attributes model)
148 (mapcar #'(lambda (x)
149 (setf (find-attribute model (car x)) (cdr x)))
150 (default-attributes model)))
151
152
153 (defgeneric attributes-getter (model))
154
155 ;;;presentations
156
157 (defcomponent mewa ()
158 ((instance :accessor instance :initarg :instance)
159 (attributes
160 :initarg :attributes
161 :accessor attributes
162 :initform nil)
163 (attributes-getter
164 :accessor attributes-getter
165 :initform #'get-attributes
166 :initarg :attributes-getter)
167 (attribute-slot-map
168 :accessor attribute-slot-map
169 :initform nil)
170 (global-properties
171 :initarg :global-properties
172 :accessor global-properties
173 :initform nil)
174 (classes
175 :initarg :classes
176 :accessor classes
177 :initform nil)
178 (use-instance-class-p
179 :initarg :use-instance-class-p
180 :accessor use-instance-class-p
181 :initform t)
182 (initializedp :initform nil)
183 (modifiedp :accessor modifiedp :initform nil :initarg :modifiedp)
184 (modifications :accessor modifications :initform nil)))
185
186
187 (defmethod attributes :around ((self mewa))
188 (let ((a (call-next-method)))
189 (or a (funcall (attributes-getter self) self))))
190
191 (defgeneric get-attributes (mewa))
192
193 (defmethod get-attributes ((self mewa))
194 (if (instance self)
195 (append (meta-model:list-slots (instance self))
196 (meta-model:list-has-many (instance self)))
197 nil))
198
199 (defmethod find-instance-classes ((self mewa))
200 (mapcar #'class-name
201 (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
202
203 (defmethod find-all-attributes ((self mewa))
204 (reduce #'append
205 (mapcar #'(lambda (x)
206 (cdr (find-class-attributes x)))
207 (classes self))))
208
209 (defun make-attribute (&rest props &key type &allow-other-keys)
210 (remf props :type)
211 (cons (gensym) (cons type props)))
212
213
214 (defmethod find-applicable-attributes ((self mewa))
215 (let ((all-attributes (find-all-attributes self)))
216 (flet ((gen-att (x) (let ((att (assoc x all-attributes)))
217 (when att
218 (setf (cddr att) (plist-union (global-properties self) (cddr att)))
219 att))))
220 (if (attributes self)
221 (remove 'nil
222 (mapcar #'(lambda (x)
223 (cond
224 ;;simple casee
225 ((symbolp x)
226 (gen-att x))
227 ;;if the car is a keyword then this is an inline def
228 ((and (listp x) (keywordp (car x)))
229 (let ((att (apply #'make-attribute x)))
230 (setf (cddr att)
231 (plist-union (cddr att) (global-properties self)))
232 att))
233 ;; if the plist has a :type
234 ((and (listp x) (getf (cdr x) :type))
235 (let ((new (cdr (apply #'make-attribute (cdr x))))
236 (def (gen-att (car x))))
237 (setf (cdr new) (plist-union (cdr new) (cddr def)))
238 (cons (car def) new)))
239 ;;finally if we are just overiding the props
240 ((and (listp x) (symbolp (car x)))
241 (let ((new (cdr (apply #'make-attribute (cdr x))))
242 (def (gen-att (car x))))
243 (setf (cdr new) (plist-union (cdr new) (cddr def)))
244 (cons (car def) (cons (second def) (cdr new)))))
245
246 )
247 )
248
249 (attributes self)))
250 all-attributes))))
251
252 (defmethod find-slot-presentation-for-attribute ((self mewa) attribute)
253 (let ((class-name
254 (or (gethash (if (consp (second attribute))
255 (car (second attribute))
256 (second attribute))
257 *presentation-slot-type-mapping*)
258 (error "Can't find slot type for ~A in ~A" attribute *presentation-slot-type-mapping* ))))
259
260 (cons (first attribute) (apply #'make-instance
261 class-name
262 (append (cddr attribute) (list :parent self :size 30))))))
263
264 (defmethod find-slot-presentations ((self mewa))
265 (mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a))
266 (find-applicable-attributes self)))
267
268 (defmethod find-attribute-slot ((self mewa) (attribute symbol))
269 (cdr (assoc attribute (attribute-slot-map self))))
270
271 (defmethod initialize-slots ((self mewa))
272 (when (instance self)
273 (when (use-instance-class-p self)
274 (setf (classes self)
275 (append (find-instance-classes self)
276 (classes self))))
277 (setf (attribute-slot-map self) (find-slot-presentations self))
278 (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self )))))
279
280 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
281 (let* ((p (make-instance 'mewa-object-presentation))
282 (a (progn (setf (slot-value p 'ucw::instance) object)
283 (initialize-slots p)
284 (assoc type (find-all-attributes p))))
285 (i (apply #'make-instance (or (second a)
286 ;; if we didnt find the type,
287 ;; use the symbol as a class.
288 (if (eql (symbol-package type)
289 (find-package 'keyword))
290 (symbol-name type)
291 type))
292 (plist-union initargs (cddr a)))))
293 (setf (slot-value i 'instance) object)
294 (initialize-slots i)
295 (setf (slot-value i 'initializedp) t)
296 i))
297
298
299 (defmethod initialize-slots-place ((place ucw::place) (mewa mewa))
300 (setf (slots mewa) (mapcar #'(lambda (x)
301 (prog1 x
302 (setf (component.place x) place)))
303 (slots mewa))))
304
305 (arnesi:defmethod/cc call-component :before ((from standard-component) (to mewa))
306 (unless (slot-value to 'initializedp)
307 (initialize-slots to))
308 (setf (slot-value to 'initializedp) t)
309 (initialize-slots-place (component.place from) to)
310 to)
311
312
313
314 (defmacro call-presentation (object &rest args)
315 `(present-object ,object :presentation (make-presentation ,object ,@args)))
316
317
318 (defcomponent about-dialog (option-dialog)
319 ((body :initarg :body)))
320
321 (defmethod render-on ((res response) (self about-dialog))
322 (call-next-method)
323 (render-on res (slot-value self 'body)))
324
325
326 (defmethod instance-is-stored-p ((instance clsql:standard-db-object))
327 (slot-value instance 'clsql-sys::view-database))
328
329 (defmethod instance-is-stored-p ((mewa mewa))
330 (instance-is-stored-p (instance mewa)))
331
332 (defaction cancel-save-instance ((self mewa))
333 (cond
334 ((instance-is-stored-p (instance self))
335 (meta-model::update-instance-from-records (instance self))
336 (answer self))
337 (t (answer nil))))
338
339 (defaction save-instance ((self mewa))
340 (meta-model:sync-instance (instance self))
341 (setf (modifiedp self) nil)
342 (answer self))
343
344
345 (defaction ensure-instance-sync ((self mewa))
346 (when (modifiedp self)
347 (let ((message (format nil "Record has been modified, Do you wish to save the changes?")))
348 (case (call 'about-dialog
349 :body (make-presentation (instance self)
350 :type :viewer)
351 :message message
352 :options '((:save . "Save changes to Database")
353 (:cancel . "Cancel all changes")))
354 (:cancel
355 (cancel-save-instance self))
356 (:save
357 (save-instance self))))))
358
359 (defaction ok ((self mewa) &optional arg)
360 "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
361 ;(declare (ignore arg))
362 (meta-model::sync-instance (instance self))
363 (answer (instance self)))
364
365 (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
366 (let* ((old (prog1
367 (presentation-slot-value slot instance)
368 (call-next-method)))
369 (new (presentation-slot-value slot instance)))
370
371 (unless (equal new old )
372 (let ((self (ucw::parent slot)))
373 (setf (modifiedp self) instance
374 (modifications self) (append (list new old value slot instance) (modifications self)))))))
375
376 ;;;; * Finally set up some defaults
377
378 (setf (find-attribute t :viewer)
379 '(mewa-object-presentation :global-properties (:editablep nil))
380 (find-attribute t :editor)
381 '(mewa-object-presentation :global-properties (:editablep t))
382 (find-attribute t :creator)
383 '(mewa-object-presentation :global-properties (:editablep t))
384 (find-attribute t :one-line)
385 '(mewa-one-line-presentation)
386 (find-attribute t :listing)
387 '(mewa-list-presentation :global-properties (:editablep nil) :editablep t)
388 (find-attribute t :search-model)
389 '(mewa-object-presentation))
390
391
392
393
394
395 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
396 ;; You are granted the rights to distribute
397 ;; and use this software as governed by the terms
398 ;; of the Lisp Lesser GNU Public License
399 ;; (http://opensource.franz.com/preamble.html),
400 ;; known as the LLGPL.