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