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