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