whole bunch of cleanups so we build
[clinton/lisp-on-lines.git] / src / mewa / mewa.lisp
CommitLineData
579597e3 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)
d0c40011 15 (loop for cons on new-props by #'cddr
579597e3 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
19531fbd 87(defmethod default-attributes ((model t))
a6644385 88 "return the default attributes for a given model using the meta-model's meta-data"
7129498f 89 (append (mapcar #'(lambda (s)
90 (cons (car s)
91 (gen-pslot
1679abef 92 (if (meta-model:foreign-key-p model (car s))
93 'ucw::foreign-key
94 (cadr s))
95 (string (car s)) (car s))))
96 (meta-model:list-slot-types model))
97 (mapcar #'(lambda (s)
98 (cons s (append (gen-pslot 'ucw::has-many (string s) s)
99 `(:presentation
100 (make-presentation
101 ,model
102 :type :one-line)))))
19531fbd 103 (meta-model:list-has-many model))))
104
105(defmethod set-default-attributes ((model t))
106 (mapcar #'(lambda (x)
107 (setf (find-attribute model (car x)) (cdr x)))
108 (default-attributes model)))
109
110
579597e3 111(defgeneric attributes-getter (model))
112
19531fbd 113;;;presentations
114
115
116
117
579597e3 118(defcomponent mewa ()
119 ((attributes
120 :initarg :attributes
121 :accessor attributes
122 :initform nil)
123 (attributes-getter
124 :accessor attributes-getter
125 :initform #'get-attributes
126 :initarg :attributes-getter)
127 (global-properties
128 :initarg :global-properties
129 :accessor global-properties
130 :initform nil)
131 (classes
132 :initarg :classes
133 :accessor classes
134 :initform nil)
135 (use-instance-class-p
136 :initarg :use-instance-class-p
137 :accessor use-instance-class-p
138 :initform t)
139 (initializedp :initform nil)
d1bb68e0 140 (modifiedp :accessor modifiedp :initform nil)
141 (modifications :accessor modifications :initform nil)))
579597e3 142
579597e3 143
144(defmethod attributes :around ((self mewa))
145 (let ((a (call-next-method)))
146 (or a (funcall (attributes-getter self) self))))
147
19531fbd 148(defgeneric get-attributes (mewa))
149
579597e3 150(defmethod get-attributes ((self mewa))
151 (if (instance self)
152 (append (meta-model:list-slots (instance self))
153 (meta-model:list-has-many (instance self)))
154 nil))
155
579597e3 156
157(defmethod find-instance-classes ((self mewa))
158 (mapcar #'class-name
159 (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
160
161(defmethod find-all-attributes ((self mewa))
162 (reduce #'append
163 (mapcar #'(lambda (x)
164 (cdr (find-class-attributes x)))
165 (classes self))))
166
167(defun make-attribute (&rest props &key type &allow-other-keys)
168 (remf props :type)
169 (cons (gensym) (cons type props)))
170
171
172(defmethod find-applicable-attributes ((self mewa))
173 (let ((all-attributes (find-all-attributes self)))
174 (flet ((gen-att (x) (let ((att (assoc x all-attributes)))
175 (when att
176 (setf (cddr att) (plist-union (global-properties self) (cddr att)))
177 att))))
178 (if (attributes self)
179 (remove 'nil
180 (mapcar #'(lambda (x)
181 (cond
182 ;;simple casee
183 ((symbolp x)
184 (gen-att x))
185 ;;if the car is a keyword then this is an inline def
186 ((and (listp x) (keywordp (car x)))
187 (let ((att (apply #'make-attribute x)))
188 (setf (cddr att)
189 (plist-union (cddr att) (global-properties self)))
190 att))
191 ;; if the plist has a :type
192 ((and (listp x) (getf (cdr x) :type))
193 (let ((new (cdr (apply #'make-attribute (cdr x))))
194 (def (gen-att (car x))))
195 (setf (cdr new) (plist-union (cdr new) (cddr def)))
196 (cons (car def) new)))
197 ;;finally if we are just overiding the props
198 ((and (listp x) (symbolp (car x)))
199 (let ((new (cdr (apply #'make-attribute (cdr x))))
200 (def (gen-att (car x))))
201 (setf (cdr new) (plist-union (cdr new) (cddr def)))
202 (cons (car def) (cons (second def) (cdr new)))))
203
204 )
205 )
206
207 (attributes self)))
208 all-attributes))))
209
210(defmethod find-slot-presentations ((self mewa))
211 (mapcar #'(lambda (s)
212 (let ((class-name (or (gethash (second s) ucw::*slot-type-mapping*) 'mewa-object-presentation)))
213 (apply #'make-instance
214 class-name
215 (append (cddr s) (list :parent self)))))
216 (find-applicable-attributes self)))
217
579597e3 218
219
220(defmethod initialize-slots ((self mewa))
221 (when (use-instance-class-p self)
222 (setf (classes self)
223 (append (find-instance-classes self)
224 (classes self))))
225 (setf (slots self) (find-slot-presentations self)))
226
227
579597e3 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 (second a) (plist-union initargs (cddr a)))))
235 (setf (slot-value i 'instance) object)
236 i))
237
19531fbd 238(defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
239 (let* ((p (make-instance 'mewa-object-presentation))
240 (a (progn (setf (slot-value p 'instance) object)
241 (initialize-slots p)
242 (assoc type (find-all-attributes p))))
243
244 (i (apply #'make-instance (or (second a)
245 ;; if we didnt find the type,
246 ;; use the symbol as a class.
247 (if (eql (symbol-package type)
248 (find-package 'keyword))
249 (symbol-name type)
250 type))
251 (plist-union initargs (cddr a)))))
252 (setf (slot-value i 'instance) object)
2acd3ba2 253 (initialize-slots i)
254 (setf (slot-value i 'initializedp) t)
19531fbd 255 i))
256
257
258
259
260
579597e3 261(defmethod call-component :before ((from standard-component) (to mewa))
262 (unless (slot-value to 'initializedp)
263 (initialize-slots to))
264 (setf (slot-value to 'initializedp) t)
265 (setf (slots to) (mapcar #'(lambda (x) (prog2
266 (setf (component.place x) (component.place from))
267 x))
268 (slots to))))
269
270(defmacro call-presentation (object &rest args)
ae09804a 271 `(present-object ,object :presentation (make-presentation ,object ,@args)))
272
273
274
275(defaction cancel-save-instance ((self mewa))
1679abef 276 (cond
277 ((slot-value (instance self) 'clsql-sys::view-database)
278 (meta-model::update-instance-from-records (instance self))
279 (answer self))
280 (t (answer nil))))
ae09804a 281
282(defaction save-instance ((self mewa))
7129498f 283 (meta-model:sync-instance (instance self))
ae09804a 284 (setf (modifiedp self) nil)
285 (answer self))
286
287
288(defaction ok ((self mewa) &optional arg)
289 "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
290 (declare (ignore arg))
291 (when (modifiedp self)
292 (let ((message (format nil "Record has been modified, Do you wish to save the changes?<br/> ~a" (print (modifications self)))))
293 (case (call 'option-dialog
294 :message message
295 :options '((:save . "Save changes to Database")
296 (:cancel . "Cancel all changes")))
297 (:cancel
298 (cancel-save-instance self))
299 (:save
300 (save-instance self)))))
301 (answer self))
302
303
304
305(defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
306 (let* ((old (prog1
307 (presentation-slot-value slot instance)
308 (call-next-method)))
309 (new (presentation-slot-value slot instance)))
310
311 (unless (equal new old )
312 (let ((self (ucw::parent slot)))
313 (setf (modifiedp self) instance
314 (modifications self) (append (list (type-of new) (type-of old) (type-of value) slot instance )))))))