added :clsql and exporting sync-instance
[clinton/lisp-on-lines.git] / src / mewa / mewa.lisp
... / ...
CommitLineData
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* '(number ucw:currency))
7
8;;; an alist of model-class-name . attributes
9;;; should really be a hash-table.
10(defvar *attribute-map* (list))
11
12;;; some utilities for merging plists
13
14(defun plist-nunion (new-props plist)
15 (loop for cons on new-props by #'cddr
16 do (setf (getf plist (first cons)) (second cons))
17 finally (return plist)))
18
19(defun plist-union (new-props plist)
20 "Non-destructive version of plist-nunion"
21 (plist-nunion new-props (copy-list plist)))
22
23(defun gen-ptype (type)
24 (or (getf *slot-type-map* type) type))
25
26(defun gen-presentation-slots (instance)
27 (mapcar #'(lambda (x) (gen-pslot (cadr x)
28 (string (car x))
29 (car x)))
30 (list-slot-types instance)))
31
32
33(defun gen-pslot (type label slot-name)
34 (copy-list `(,(gen-ptype type)
35 :label ,label
36 :slot-name ,slot-name)))
37
38(defun gen-presentation-args (instance args)
39 (declare (ignore instance))
40 (if args args nil))
41
42
43(defun find-or-create-attributes (class-name)
44 "return an exisiting class attribute map or create one.
45
46A map is a cons of class-name . attributes.
47attributes is an alist keyed on the attribute nreeame."
48 (or (assoc class-name *attribute-map*)
49 (progn
50 (setf *attribute-map* (acons class-name (list (list)) *attribute-map*))
51 (assoc class-name *attribute-map*))))
52
53(defgeneric find-class-attributes (class))
54
55(defmethod find-class-attributes ((model t))
56 (find-or-create-attributes (class-name (class-of model))))
57
58(defmethod find-class-attributes ((model symbol))
59 (find-or-create-attributes model))
60
61(defmethod add-attribute ((model t) name def)
62 (let ((map (find-class-attributes model)))
63 (setf (cdr map) (acons name def (cdr map)))))
64
65(defmethod find-attribute ((model t) name)
66 (assoc name (cdr (find-class-attributes model))))
67
68(defmethod (setf find-attribute) ((def list) (model t) name)
69 (let ((attr (find-attribute model name)))
70 (if attr
71 (prog2
72 (setf (cdr attr) def)
73 attr)
74 (prog2
75 (add-attribute model name def)
76 (find-attribute model name)))))
77
78(defmethod set-attribute ((model t) name definition &key (inherit t))
79 (setf (find-attribute model name)
80 (if inherit
81 (cons (car definition)
82 (plist-union (cdr definition)
83 (cddr (find-attribute model name))))
84 definition)))
85
86
87(defmethod default-attributes ((model t))
88 (append (mapcar #'(lambda (s) (cons (car s) (gen-pslot (if (meta-model:foreign-key-p model (car s))
89 (cadr s))
90 (string (car s)) (car s))))
91 (meta-model:list-slot-types model))
92 (mapcar #'(lambda (s) (cons s (append (gen-pslot 'ucw::has-many (string s) s) `(:presentation (make-presentation ,model :type :one-line)))))
93 (meta-model:list-has-many model))))
94
95(defmethod set-default-attributes ((model t))
96 (mapcar #'(lambda (x)
97 (setf (find-attribute model (car x)) (cdr x)))
98 (default-attributes model)))
99
100
101(defgeneric attributes-getter (model))
102
103;;;presentations
104
105
106
107
108(defcomponent mewa ()
109 ((attributes
110 :initarg :attributes
111 :accessor attributes
112 :initform nil)
113 (attributes-getter
114 :accessor attributes-getter
115 :initform #'get-attributes
116 :initarg :attributes-getter)
117 (global-properties
118 :initarg :global-properties
119 :accessor global-properties
120 :initform nil)
121 (classes
122 :initarg :classes
123 :accessor classes
124 :initform nil)
125 (use-instance-class-p
126 :initarg :use-instance-class-p
127 :accessor use-instance-class-p
128 :initform t)
129 (initializedp :initform nil)
130 (modifiedp :accessor modifiedp :initform nil)
131 (modifications :accessor modifications :initform nil)))
132
133
134(defmethod attributes :around ((self mewa))
135 (let ((a (call-next-method)))
136 (or a (funcall (attributes-getter self) self))))
137
138(defgeneric get-attributes (mewa))
139
140(defmethod get-attributes ((self mewa))
141 (if (instance self)
142 (append (meta-model:list-slots (instance self))
143 (meta-model:list-has-many (instance self)))
144 nil))
145
146
147(defmethod find-instance-classes ((self mewa))
148 (mapcar #'class-name
149 (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
150
151(defmethod find-all-attributes ((self mewa))
152 (reduce #'append
153 (mapcar #'(lambda (x)
154 (cdr (find-class-attributes x)))
155 (classes self))))
156
157(defun make-attribute (&rest props &key type &allow-other-keys)
158 (remf props :type)
159 (cons (gensym) (cons type props)))
160
161
162(defmethod find-applicable-attributes ((self mewa))
163 (let ((all-attributes (find-all-attributes self)))
164 (flet ((gen-att (x) (let ((att (assoc x all-attributes)))
165 (when att
166 (setf (cddr att) (plist-union (global-properties self) (cddr att)))
167 att))))
168 (if (attributes self)
169 (remove 'nil
170 (mapcar #'(lambda (x)
171 (cond
172 ;;simple casee
173 ((symbolp x)
174 (gen-att x))
175 ;;if the car is a keyword then this is an inline def
176 ((and (listp x) (keywordp (car x)))
177 (let ((att (apply #'make-attribute x)))
178 (setf (cddr att)
179 (plist-union (cddr att) (global-properties self)))
180 att))
181 ;; if the plist has a :type
182 ((and (listp x) (getf (cdr x) :type))
183 (let ((new (cdr (apply #'make-attribute (cdr x))))
184 (def (gen-att (car x))))
185 (setf (cdr new) (plist-union (cdr new) (cddr def)))
186 (cons (car def) new)))
187 ;;finally if we are just overiding the props
188 ((and (listp x) (symbolp (car x)))
189 (let ((new (cdr (apply #'make-attribute (cdr x))))
190 (def (gen-att (car x))))
191 (setf (cdr new) (plist-union (cdr new) (cddr def)))
192 (cons (car def) (cons (second def) (cdr new)))))
193
194 )
195 )
196
197 (attributes self)))
198 all-attributes))))
199
200(defmethod find-slot-presentations ((self mewa))
201 (mapcar #'(lambda (s)
202 (let ((class-name (or (gethash (second s) ucw::*slot-type-mapping*) 'mewa-object-presentation)))
203 (apply #'make-instance
204 class-name
205 (append (cddr s) (list :parent self)))))
206 (find-applicable-attributes self)))
207
208
209
210(defmethod initialize-slots ((self mewa))
211 (when (use-instance-class-p self)
212 (setf (classes self)
213 (append (find-instance-classes self)
214 (classes self))))
215 (setf (slots self) (find-slot-presentations self)))
216
217
218(defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
219 (let* ((p (make-instance 'mewa-object-presentation))
220 (a (progn (setf (slot-value p 'instance) object)
221 (initialize-slots p)
222 (assoc type (find-all-attributes p))))
223
224 (i (apply #'make-instance (second a) (plist-union initargs (cddr a)))))
225 (setf (slot-value i 'instance) object)
226 i))
227
228(defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
229 (let* ((p (make-instance 'mewa-object-presentation))
230 (a (progn (setf (slot-value p 'instance) object)
231 (initialize-slots p)
232 (assoc type (find-all-attributes p))))
233
234 (i (apply #'make-instance (or (second a)
235 ;; if we didnt find the type,
236 ;; use the symbol as a class.
237 (if (eql (symbol-package type)
238 (find-package 'keyword))
239 (symbol-name type)
240 type))
241 (plist-union initargs (cddr a)))))
242 (setf (slot-value i 'instance) object)
243 (initialize-slots i)
244 (setf (slot-value i 'initializedp) t)
245 i))
246
247
248
249
250
251(defmethod call-component :before ((from standard-component) (to mewa))
252 (unless (slot-value to 'initializedp)
253 (initialize-slots to))
254 (setf (slot-value to 'initializedp) t)
255 (setf (slots to) (mapcar #'(lambda (x) (prog2
256 (setf (component.place x) (component.place from))
257 x))
258 (slots to))))
259
260(defmacro call-presentation (object &rest args)
261 `(present-object ,object :presentation (make-presentation ,object ,@args)))
262
263
264
265(defaction cancel-save-instance ((self mewa))
266 (answer nil))
267
268(defaction save-instance ((self mewa))
269 (meta-modqel:sync-instance (instance self))
270 (setf (modifiedp self) nil)
271 (answer self))
272
273
274(defaction ok ((self mewa) &optional arg)
275 "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
276 (declare (ignore arg))
277 (when (modifiedp self)
278 (let ((message (format nil "Record has been modified, Do you wish to save the changes?<br/> ~a" (print (modifications self)))))
279 (case (call 'option-dialog
280 :message message
281 :options '((:save . "Save changes to Database")
282 (:cancel . "Cancel all changes")))
283 (:cancel
284 (cancel-save-instance self))
285 (:save
286 (save-instance self)))))
287 (answer self))
288
289
290
291(defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
292 (let* ((old (prog1
293 (presentation-slot-value slot instance)
294 (call-next-method)))
295 (new (presentation-slot-value slot instance)))
296
297 (unless (equal new old )
298 (let ((self (ucw::parent slot)))
299 (setf (modifiedp self) instance
300 (modifications self) (append (list (type-of new) (type-of old) (type-of value) slot instance )))))))