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