af4ecbb355ed69a6a90a989e6016547327604af5
[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 mewa-boolean
8 string mewa-string
9 number mewa-currency
10 integer mewa-integer
11 currency mewa-currency))
12
13 ;;; an alist of model-class-name . attributes
14 ;;; should really be a hash-table.
15 (defvar *attribute-map* (list))
16
17 ;;; some utilities for merging plists
18
19 (defun plist-nunion (new-props plist)
20 (loop for cons on new-props by #'cddr
21 do (setf (getf plist (first cons)) (second cons))
22 finally (return plist)))
23
24 (defun plist-union (new-props plist)
25 "Non-destructive version of plist-nunion"
26 (plist-nunion new-props (copy-list plist)))
27
28 (defun gen-ptype (type)
29 (or (getf *slot-type-map* type) type))
30
31 (defun gen-presentation-slots (instance)
32 (mapcar #'(lambda (x) (gen-pslot (cadr x)
33 (string (car x))
34 (car x)))
35 (meta-model:list-slot-types instance)))
36
37
38 (defun gen-pslot (type label slot-name)
39 (copy-list `(,(gen-ptype type)
40 :label ,label
41 :slot-name ,slot-name)))
42
43 (defun gen-presentation-args (instance args)
44 (declare (ignore instance))
45 (if args args nil))
46
47
48 (defun find-or-create-attributes (class-name)
49 "return an exisiting class attribute map or create one.
50
51 A map is a cons of class-name . attributes.
52 attributes is an alist keyed on the attribute name."
53 (or (assoc class-name *attribute-map*)
54 (progn
55 (setf *attribute-map* (acons class-name (list (list)) *attribute-map*))
56 (assoc class-name *attribute-map*))))
57
58 (defgeneric find-class-attributes (class))
59
60 (defmethod find-class-attributes ((model t))
61 (find-or-create-attributes (class-name (class-of model))))
62
63 (defmethod find-class-attributes ((model symbol))
64 (find-or-create-attributes model))
65
66 (defmethod clear-class-attributes ((model t))
67 (setf (cdr (find-class-attributes model)) nil))
68
69 (defmethod add-attribute ((model t) name def)
70 (let ((map (find-class-attributes model)))
71 (setf (cdr map) (acons name def (cdr map)))))
72
73 (defmethod find-attribute ((model t) name)
74 (assoc name (cdr (find-class-attributes model))))
75
76 (defmethod (setf find-attribute) ((def list) (model t) name)
77 (let ((attr (find-attribute model name)))
78 (if attr
79 (prog2
80 (setf (cdr attr) def)
81 attr)
82 (prog2
83 (add-attribute model name def)
84 (find-attribute model name)))))
85
86 (defmethod set-attribute ((model t) name definition &key (inherit t))
87 (setf (find-attribute model name)
88 (if inherit
89 (cons (car definition)
90 (plist-union (cdr definition)
91 (cddr (find-attribute model name))))
92 definition)))
93
94 (defmethod perform-set-attributes ((model t) definitions)
95 (dolist (def definitions)
96 (funcall #'set-attribute model (first def) (rest def))))
97
98 (defmethod set-attribute-properties ((model t) attribute properties)
99 (let ((a (find-attribute model attribute)))
100 (if a
101 (setf (cddr a) (plist-nunion properties (cddr a)))
102 (error "Attribute ~A does not exist" attribute) )))
103
104 (defmethod perform-set-attribute-properties ((model t) definitions)
105 (dolist (def definitions)
106 (funcall #'set-attribute-properties model (car def) (cdr def))))
107
108
109 (defmethod default-attributes ((model t))
110 "return the default attributes for a given model using the meta-model's meta-data"
111 (append (mapcar #'(lambda (s)
112 (cons (car s)
113 (gen-pslot
114 (if (meta-model:foreign-key-p model (car s))
115 'foreign-key
116 (cadr s))
117 (string (car s)) (car s))))
118 (meta-model:list-slot-types model))
119 (mapcar #'(lambda (s)
120 (cons s (append (gen-pslot 'has-many (string s) s)
121 `(:presentation
122 (make-presentation
123 ,model
124 :type :one-line)))))
125 (meta-model:list-has-many model))))
126
127 (defmethod set-default-attributes ((model t))
128 "Set the default attributes for MODEL"
129 (clear-class-attributes model)
130 (mapcar #'(lambda (x)
131 (setf (find-attribute model (car x)) (cdr x)))
132 (default-attributes model)))
133
134
135 (defgeneric attributes-getter (model))
136
137 ;;;presentations
138
139
140
141 (defcomponent mewa ()
142 ((instance :accessor instance :initarg :instance)
143 (attributes
144 :initarg :attributes
145 :accessor attributes
146 :initform nil)
147 (attributes-getter
148 :accessor attributes-getter
149 :initform #'get-attributes
150 :initarg :attributes-getter)
151 (attribute-slot-map
152 :accessor attribute-slot-map
153 :initform nil)
154 (global-properties
155 :initarg :global-properties
156 :accessor global-properties
157 :initform nil)
158 (classes
159 :initarg :classes
160 :accessor classes
161 :initform nil)
162 (use-instance-class-p
163 :initarg :use-instance-class-p
164 :accessor use-instance-class-p
165 :initform t)
166 (initializedp :initform nil)
167 (modifiedp :accessor modifiedp :initform nil :initarg :modifiedp)
168 (modifications :accessor modifications :initform nil)))
169
170
171 (defmethod attributes :around ((self mewa))
172 (let ((a (call-next-method)))
173 (or a (funcall (attributes-getter self) self))))
174
175 (defgeneric get-attributes (mewa))
176
177 (defmethod get-attributes ((self mewa))
178 (if (instance self)
179 (append (meta-model:list-slots (instance self))
180 (meta-model:list-has-many (instance self)))
181 nil))
182
183 (defmethod find-instance-classes ((self mewa))
184 (mapcar #'class-name
185 (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
186
187 (defmethod find-all-attributes ((self mewa))
188 (reduce #'append
189 (mapcar #'(lambda (x)
190 (cdr (find-class-attributes x)))
191 (classes self))))
192
193 (defun make-attribute (&rest props &key type &allow-other-keys)
194 (remf props :type)
195 (cons (gensym) (cons type props)))
196
197
198 (defmethod find-applicable-attributes ((self mewa))
199 (let ((all-attributes (find-all-attributes self)))
200 (flet ((gen-att (x) (let ((att (assoc x all-attributes)))
201 (when att
202 (setf (cddr att) (plist-union (global-properties self) (cddr att)))
203 att))))
204 (if (attributes self)
205 (remove 'nil
206 (mapcar #'(lambda (x)
207 (cond
208 ;;simple casee
209 ((symbolp x)
210 (gen-att x))
211 ;;if the car is a keyword then this is an inline def
212 ((and (listp x) (keywordp (car x)))
213 (let ((att (apply #'make-attribute x)))
214 (setf (cddr att)
215 (plist-union (cddr att) (global-properties self)))
216 att))
217 ;; if the plist has a :type
218 ((and (listp x) (getf (cdr x) :type))
219 (let ((new (cdr (apply #'make-attribute (cdr x))))
220 (def (gen-att (car x))))
221 (setf (cdr new) (plist-union (cdr new) (cddr def)))
222 (cons (car def) new)))
223 ;;finally if we are just overiding the props
224 ((and (listp x) (symbolp (car x)))
225 (let ((new (cdr (apply #'make-attribute (cdr x))))
226 (def (gen-att (car x))))
227 (setf (cdr new) (plist-union (cdr new) (cddr def)))
228 (cons (car def) (cons (second def) (cdr new)))))
229
230 )
231 )
232
233 (attributes self)))
234 all-attributes))))
235
236 (defmethod find-slot-presentation-for-attribute ((self mewa) attribute)
237 (let ((class-name
238 (or (gethash (if (consp (second attribute))
239 (car (second attribute))
240 (second attribute))
241 *presentation-slot-type-mapping*)
242 (error "Can't find slot type for ~A in ~A but ~A" attribute *presentation-slot-type-mapping* (gethash 'mewa:has-very-many *presentation-slot-type-mapping*)))))
243
244 (cons (first attribute) (apply #'make-instance
245 class-name
246 (append (cddr attribute) (list :parent self :size 30))))))
247
248 (defmethod find-slot-presentations ((self mewa))
249 (mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a))
250 (find-applicable-attributes self)))
251
252 (defmethod find-attribute-slot ((self mewa) (attribute symbol))
253 (cdr (assoc attribute (attribute-slot-map self))))
254
255 (defmethod initialize-slots ((self mewa))
256 (when (instance self)
257 (when (use-instance-class-p self)
258 (setf (classes self)
259 (append (find-instance-classes self)
260 (classes self))))
261 (setf (attribute-slot-map self) (find-slot-presentations self))
262 (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self )))))
263
264 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
265 (let* ((p (make-instance 'mewa-object-presentation))
266 (a (progn (setf (slot-value p 'ucw::instance) object)
267 (initialize-slots p)
268 (assoc type (find-all-attributes p))))
269 (i (apply #'make-instance (or (second a)
270 ;; if we didnt find the type,
271 ;; use the symbol as a class.
272 (if (eql (symbol-package type)
273 (find-package 'keyword))
274 (symbol-name type)
275 type))
276 (plist-union initargs (cddr a)))))
277 (setf (slot-value i 'instance) object)
278 (initialize-slots i)
279 (setf (slot-value i 'initializedp) t)
280 i))
281
282
283 (defmethod initialize-slots-place ((place ucw::place) (mewa mewa))
284 (setf (slots mewa) (mapcar #'(lambda (x)
285 (prog1 x
286 (setf (component.place x) place)))
287 (slots mewa))))
288
289 (arnesi:defmethod/cc call-component :before ((from standard-component) (to mewa))
290 (unless (slot-value to 'initializedp)
291 (initialize-slots to))
292 (setf (slot-value to 'initializedp) t)
293 (initialize-slots-place (component.place from) to)
294 to)
295
296
297
298 (defmacro call-presentation (object &rest args)
299 `(present-object ,object :presentation (make-presentation ,object ,@args)))
300
301
302 (defcomponent about-dialog (option-dialog)
303 ((body :initarg :body)))
304
305 (defmethod render-on ((res response) (self about-dialog))
306 (call-next-method)
307 (render-on res (slot-value self 'body)))
308
309
310 (defmethod instance-is-stored-p ((instance clsql:standard-db-object))
311 (slot-value instance 'clsql-sys::view-database))
312
313 (defmethod instance-is-stored-p ((mewa mewa))
314 (instance-is-stored-p (instance mewa)))
315
316 (defaction cancel-save-instance ((self mewa))
317 (cond
318 ((instance-is-stored-p (instance self))
319 (meta-model::update-instance-from-records (instance self))
320 (answer self))
321 (t (answer nil))))
322
323 (defaction save-instance ((self mewa))
324 (meta-model:sync-instance (instance self))
325 (setf (modifiedp self) nil)
326 (answer self))
327
328
329 (defaction ensure-instance-sync ((self mewa))
330 (when (modifiedp self)
331 (let ((message (format nil "Record has been modified, Do you wish to save the changes?")))
332 (case (call 'about-dialog
333 :body (make-presentation (instance self)
334 :type :viewer)
335 :message message
336 :options '((:save . "Save changes to Database")
337 (:cancel . "Cancel all changes")))
338 (:cancel
339 (cancel-save-instance self))
340 (:save
341 (save-instance self))))))
342
343 (defaction ok ((self mewa) &optional arg)
344 "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
345 ;(declare (ignore arg))
346 (meta-model::sync-instance (instance self))
347 (answer (instance self)))
348
349 (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
350 (let* ((old (prog1
351 (presentation-slot-value slot instance)
352 (call-next-method)))
353 (new (presentation-slot-value slot instance)))
354
355 (unless (equal new old )
356 (let ((self (ucw::parent slot)))
357 (setf (modifiedp self) instance
358 (modifications self) (append (list new old value slot instance) (modifications self)))))))
359
360 ;;;; * Finally set up some defaults
361
362 (setf (find-attribute t :viewer)
363 '(mewa-object-presentation :global-properties (:editablep nil))
364 (find-attribute t :editor)
365 '(mewa-object-presentation :global-properties (:editablep t))
366 (find-attribute t :creator)
367 '(mewa-object-presentation :global-properties (:editablep t))
368 (find-attribute t :one-line)
369 '(mewa-one-line-presentation)
370 (find-attribute t :listing)
371 '(mewa-list-presentation :global-properties (:editablep nil) :editablep t)
372 (find-attribute t :search-model)
373 '(mewa-object-presentation))
374
375
376
377
378
379 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
380 ;; You are granted the rights to distribute
381 ;; and use this software as governed by the terms
382 ;; of the Lisp Lesser GNU Public License
383 ;; (http://opensource.franz.com/preamble.html),
384 ;; known as the LLGPL.