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