added a clear-class-attributes method, and added it to set-default-attributes so...
[clinton/lisp-on-lines.git] / src / mewa / mewa.lisp
1
2 (in-package :mewa)
3
4 (defparameter *default-type* :ucw)
5
6 ;;; maps meta-model slot-types to slot-presentation
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 ))
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)
22 (loop for cons on new-props by #'cddr
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)))
37 (meta-model:list-slot-types instance)))
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
53 A map is a cons of class-name . attributes.
54 attributes 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
68 (defmethod clear-class-attributes ((model t))
69 (setf (cdr (find-class-attributes model)) nil))
70
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
96 (defmethod perform-set-attributes ((model t) definitions)
97 (dolist (def definitions)
98 (funcall #'set-attribute model (first def) (rest def))))
99
100 (defmethod default-attributes ((model t))
101 "return the default attributes for a given model using the meta-model's meta-data"
102 (append (mapcar #'(lambda (s)
103 (cons (car s)
104 (gen-pslot
105 (if (meta-model:foreign-key-p model (car s))
106 'ucw::foreign-key
107 (cadr s))
108 (string (car s)) (car s))))
109 (meta-model:list-slot-types model))
110 (mapcar #'(lambda (s)
111 (cons s (append (gen-pslot 'ucw::has-many (string s) s)
112 `(:presentation
113 (make-presentation
114 ,model
115 :type :one-line)))))
116 (meta-model:list-has-many model))))
117
118 (defmethod set-default-attributes ((model t))
119 (clear-class-attributes model)
120 (mapcar #'(lambda (x)
121 (setf (find-attribute model (car x)) (cdr x)))
122 (default-attributes model)))
123
124
125 (defgeneric attributes-getter (model))
126
127 ;;;presentations
128
129
130
131
132 (defcomponent mewa ()
133 ((attributes
134 :initarg :attributes
135 :accessor attributes
136 :initform nil)
137 (attributes-getter
138 :accessor attributes-getter
139 :initform #'get-attributes
140 :initarg :attributes-getter)
141 (global-properties
142 :initarg :global-properties
143 :accessor global-properties
144 :initform nil)
145 (classes
146 :initarg :classes
147 :accessor classes
148 :initform nil)
149 (use-instance-class-p
150 :initarg :use-instance-class-p
151 :accessor use-instance-class-p
152 :initform t)
153 (initializedp :initform nil)
154 (modifiedp :accessor modifiedp :initform nil)
155 (modifications :accessor modifications :initform nil)))
156
157
158 (defmethod attributes :around ((self mewa))
159 (let ((a (call-next-method)))
160 (or a (funcall (attributes-getter self) self))))
161
162 (defgeneric get-attributes (mewa))
163
164 (defmethod get-attributes ((self mewa))
165 (if (instance self)
166 (append (meta-model:list-slots (instance self))
167 (meta-model:list-has-many (instance self)))
168 nil))
169
170
171 (defmethod find-instance-classes ((self mewa))
172 (mapcar #'class-name
173 (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
174
175 (defmethod find-all-attributes ((self mewa))
176 (reduce #'append
177 (mapcar #'(lambda (x)
178 (cdr (find-class-attributes x)))
179 (classes self))))
180
181 (defun make-attribute (&rest props &key type &allow-other-keys)
182 (remf props :type)
183 (cons (gensym) (cons type props)))
184
185
186 (defmethod find-applicable-attributes ((self mewa))
187 (let ((all-attributes (find-all-attributes self)))
188 (flet ((gen-att (x) (let ((att (assoc x all-attributes)))
189 (when att
190 (setf (cddr att) (plist-union (global-properties self) (cddr att)))
191 att))))
192 (if (attributes self)
193 (remove 'nil
194 (mapcar #'(lambda (x)
195 (cond
196 ;;simple casee
197 ((symbolp x)
198 (gen-att x))
199 ;;if the car is a keyword then this is an inline def
200 ((and (listp x) (keywordp (car x)))
201 (let ((att (apply #'make-attribute x)))
202 (setf (cddr att)
203 (plist-union (cddr att) (global-properties self)))
204 att))
205 ;; if the plist has a :type
206 ((and (listp x) (getf (cdr x) :type))
207 (let ((new (cdr (apply #'make-attribute (cdr x))))
208 (def (gen-att (car x))))
209 (setf (cdr new) (plist-union (cdr new) (cddr def)))
210 (cons (car def) new)))
211 ;;finally if we are just overiding the props
212 ((and (listp x) (symbolp (car x)))
213 (let ((new (cdr (apply #'make-attribute (cdr x))))
214 (def (gen-att (car x))))
215 (setf (cdr new) (plist-union (cdr new) (cddr def)))
216 (cons (car def) (cons (second def) (cdr new)))))
217
218 )
219 )
220
221 (attributes self)))
222 all-attributes))))
223
224 (defmethod find-slot-presentations ((self mewa))
225 (mapcar #'(lambda (s)
226 (let ((class-name (or (gethash (second s) ucw::*slot-type-mapping*) 'mewa-object-presentation)))
227 (apply #'make-instance
228 class-name
229 (append (cddr s) (list :parent self)))))
230 (find-applicable-attributes self)))
231
232
233
234 (defmethod initialize-slots ((self mewa))
235 (when (use-instance-class-p self)
236 (setf (classes self)
237 (append (find-instance-classes self)
238 (classes self))))
239 (setf (slots self) (find-slot-presentations self)))
240
241
242 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
243 (let* ((p (make-instance 'mewa-object-presentation))
244 (a (progn (setf (slot-value p 'instance) object)
245 (initialize-slots p)
246 (assoc type (find-all-attributes p))))
247
248 (i (apply #'make-instance (second a) (plist-union initargs (cddr a)))))
249 (setf (slot-value i 'instance) object)
250 i))
251
252 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
253 (let* ((p (make-instance 'mewa-object-presentation))
254 (a (progn (setf (slot-value p 'instance) object)
255 (initialize-slots p)
256 (assoc type (find-all-attributes p))))
257
258 (i (apply #'make-instance (or (second a)
259 ;; if we didnt find the type,
260 ;; use the symbol as a class.
261 (if (eql (symbol-package type)
262 (find-package 'keyword))
263 (symbol-name type)
264 type))
265 (plist-union initargs (cddr a)))))
266 (setf (slot-value i 'instance) object)
267 (initialize-slots i)
268 (setf (slot-value i 'initializedp) t)
269 i))
270
271
272
273
274
275 (defmethod call-component :before ((from standard-component) (to mewa))
276 (unless (slot-value to 'initializedp)
277 (initialize-slots to))
278 (setf (slot-value to 'initializedp) t)
279 (setf (slots to) (mapcar #'(lambda (x) (prog2
280 (setf (component.place x) (component.place from))
281 x))
282 (slots to))))
283
284 (defmacro call-presentation (object &rest args)
285 `(present-object ,object :presentation (make-presentation ,object ,@args)))
286
287
288 (defcomponent about-dialog (option-dialog)
289 ((body :initarg :body)))
290
291 (defmethod render-on ((res response) (self about-dialog))
292 (render-on res (slot-value self 'body))
293 (call-next-method))
294
295 (defaction cancel-save-instance ((self mewa))
296 (cond
297 ((slot-value (instance self) 'clsql-sys::view-database)
298 (meta-model::update-instance-from-records (instance self))
299 (answer self))
300 (t (answer nil))))
301
302 (defaction save-instance ((self mewa))
303 (meta-model:sync-instance (instance self))
304 (setf (modifiedp self) nil)
305 (answer self))
306
307
308 (defaction ensure-instance-sync ((self mewa))
309 (when (modifiedp self)
310 (let ((message (format nil "Record has been modified, Do you wish to save the changes?<br/> ~a" (print (modifications self)))))
311 (case (call 'about-dialog
312 :body (make-presentation (instance self)
313 :type :viewer)
314 :message message
315 :options '((:save . "Save changes to Database")
316 (:cancel . "Cancel all changes")))
317 (:cancel
318 (cancel-save-instance self))
319 (:save
320 (save-instance self))))))
321
322 (defaction ok ((self mewa) &optional arg)
323 "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
324 (declare (ignore arg))
325 (ensure-instance-sync self)
326 (answer self))
327
328
329
330
331
332 (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
333 (let* ((old (prog1
334 (presentation-slot-value slot instance)
335 (call-next-method)))
336 (new (presentation-slot-value slot instance)))
337
338 (unless (equal new old )
339 (let ((self (ucw::parent slot)))
340 (setf (modifiedp self) instance
341 (modifications self) (append (list new old value slot instance) (modifications self)))))))
342
343
344 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
345 ;; You are granted the rights to distribute
346 ;; and use this software as governed by the terms
347 ;; of the Lisp Lesser GNU Public License
348 ;; (http://opensource.franz.com/preamble.html),
349 ;; known as the LLGPL.