lots of great changes to update along with maxwell 0.8
[clinton/lisp-on-lines.git] / src / mewa / mewa.lisp
CommitLineData
233380f7 1
579597e3 2(in-package :mewa)
3
4(defparameter *default-type* :ucw)
5
6;;; maps meta-model slot-types to slot-presentation
9d6c69fb
DC
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 ))
579597e3 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)
d0c40011 22 (loop for cons on new-props by #'cddr
579597e3 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)))
9d6c69fb 37 (meta-model:list-slot-types instance)))
579597e3 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.
8e6e6b56 54attributes is an alist keyed on the attribute name."
579597e3 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
46cea8c8
DC
68(defmethod clear-class-attributes ((model t))
69 (setf (cdr (find-class-attributes model)) nil))
70
579597e3 71(defmethod add-attribute ((model t) name def)
72 (let ((map (find-class-attributes model)))
73 (setf (cdr map) (acons name def (cdr map)))))
74
75(defmethod find-attribute ((model t) name)
76 (assoc name (cdr (find-class-attributes model))))
77
78(defmethod (setf find-attribute) ((def list) (model t) name)
79 (let ((attr (find-attribute model name)))
80 (if attr
81 (prog2
82 (setf (cdr attr) def)
83 attr)
84 (prog2
85 (add-attribute model name def)
86 (find-attribute model name)))))
87
88(defmethod set-attribute ((model t) name definition &key (inherit t))
89 (setf (find-attribute model name)
90 (if inherit
91 (cons (car definition)
92 (plist-union (cdr definition)
93 (cddr (find-attribute model name))))
94 definition)))
95
e8e743d7 96(defmethod perform-set-attributes ((model t) definitions)
97 (dolist (def definitions)
98 (funcall #'set-attribute model (first def) (rest def))))
579597e3 99
34e8e2d6
DC
100(defmethod set-attribute-properties ((model t) attribute properties)
101 (let ((a (find-attribute model attribute)))
102 (if a
103 (setf (cddr a) (plist-nunion properties (cddr a)))
104 (error "Attribute ~A does not exist" attribute) )))
105
106(defmethod perform-set-attribute-properties ((model t) definitions)
107 (dolist (def definitions)
108 (funcall #'set-attribute-properties model (car def) (cdr def))))
109
110
19531fbd 111(defmethod default-attributes ((model t))
a6644385 112 "return the default attributes for a given model using the meta-model's meta-data"
7129498f 113 (append (mapcar #'(lambda (s)
114 (cons (car s)
115 (gen-pslot
1679abef 116 (if (meta-model:foreign-key-p model (car s))
117 'ucw::foreign-key
118 (cadr s))
119 (string (car s)) (car s))))
120 (meta-model:list-slot-types model))
121 (mapcar #'(lambda (s)
122 (cons s (append (gen-pslot 'ucw::has-many (string s) s)
123 `(:presentation
124 (make-presentation
125 ,model
126 :type :one-line)))))
19531fbd 127 (meta-model:list-has-many model))))
128
129(defmethod set-default-attributes ((model t))
8e6e6b56 130 "Set the default attributes for MODEL"
46cea8c8 131 (clear-class-attributes model)
19531fbd 132 (mapcar #'(lambda (x)
133 (setf (find-attribute model (car x)) (cdr x)))
134 (default-attributes model)))
135
136
579597e3 137(defgeneric attributes-getter (model))
138
19531fbd 139;;;presentations
140
141
142
579597e3 143(defcomponent mewa ()
144 ((attributes
145 :initarg :attributes
146 :accessor attributes
147 :initform nil)
148 (attributes-getter
149 :accessor attributes-getter
150 :initform #'get-attributes
151 :initarg :attributes-getter)
152 (global-properties
153 :initarg :global-properties
154 :accessor global-properties
155 :initform nil)
156 (classes
157 :initarg :classes
158 :accessor classes
159 :initform nil)
160 (use-instance-class-p
161 :initarg :use-instance-class-p
162 :accessor use-instance-class-p
163 :initform t)
164 (initializedp :initform nil)
8e6e6b56 165 (modifiedp :accessor modifiedp :initform nil :initarg :modifiedp)
d1bb68e0 166 (modifications :accessor modifications :initform nil)))
579597e3 167
579597e3 168
169(defmethod attributes :around ((self mewa))
170 (let ((a (call-next-method)))
171 (or a (funcall (attributes-getter self) self))))
172
19531fbd 173(defgeneric get-attributes (mewa))
174
579597e3 175(defmethod get-attributes ((self mewa))
176 (if (instance self)
177 (append (meta-model:list-slots (instance self))
178 (meta-model:list-has-many (instance self)))
179 nil))
180
579597e3 181
182(defmethod find-instance-classes ((self mewa))
183 (mapcar #'class-name
184 (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
185
186(defmethod find-all-attributes ((self mewa))
187 (reduce #'append
188 (mapcar #'(lambda (x)
189 (cdr (find-class-attributes x)))
190 (classes self))))
191
192(defun make-attribute (&rest props &key type &allow-other-keys)
193 (remf props :type)
194 (cons (gensym) (cons type props)))
195
196
197(defmethod find-applicable-attributes ((self mewa))
198 (let ((all-attributes (find-all-attributes self)))
199 (flet ((gen-att (x) (let ((att (assoc x all-attributes)))
200 (when att
201 (setf (cddr att) (plist-union (global-properties self) (cddr att)))
202 att))))
203 (if (attributes self)
204 (remove 'nil
205 (mapcar #'(lambda (x)
206 (cond
207 ;;simple casee
208 ((symbolp x)
209 (gen-att x))
210 ;;if the car is a keyword then this is an inline def
211 ((and (listp x) (keywordp (car x)))
212 (let ((att (apply #'make-attribute x)))
213 (setf (cddr att)
214 (plist-union (cddr att) (global-properties self)))
215 att))
216 ;; if the plist has a :type
217 ((and (listp x) (getf (cdr x) :type))
218 (let ((new (cdr (apply #'make-attribute (cdr x))))
219 (def (gen-att (car x))))
220 (setf (cdr new) (plist-union (cdr new) (cddr def)))
221 (cons (car def) new)))
222 ;;finally if we are just overiding the props
223 ((and (listp x) (symbolp (car x)))
224 (let ((new (cdr (apply #'make-attribute (cdr x))))
225 (def (gen-att (car x))))
226 (setf (cdr new) (plist-union (cdr new) (cddr def)))
227 (cons (car def) (cons (second def) (cdr new)))))
228
229 )
230 )
231
232 (attributes self)))
233 all-attributes))))
234
235(defmethod find-slot-presentations ((self mewa))
236 (mapcar #'(lambda (s)
237 (let ((class-name (or (gethash (second s) ucw::*slot-type-mapping*) 'mewa-object-presentation)))
238 (apply #'make-instance
239 class-name
f3262348 240 (append (cddr s) (list :parent self :size 30)))))
579597e3 241 (find-applicable-attributes self)))
242
579597e3 243
244
245(defmethod initialize-slots ((self mewa))
246 (when (use-instance-class-p self)
247 (setf (classes self)
248 (append (find-instance-classes self)
249 (classes self))))
250 (setf (slots self) (find-slot-presentations self)))
251
252
579597e3 253(defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
254 (let* ((p (make-instance 'mewa-object-presentation))
255 (a (progn (setf (slot-value p 'instance) object)
256 (initialize-slots p)
257 (assoc type (find-all-attributes p))))
258
259 (i (apply #'make-instance (second a) (plist-union initargs (cddr a)))))
260 (setf (slot-value i 'instance) object)
261 i))
262
19531fbd 263(defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
264 (let* ((p (make-instance 'mewa-object-presentation))
265 (a (progn (setf (slot-value p 'instance) object)
266 (initialize-slots p)
267 (assoc type (find-all-attributes p))))
268
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)
2acd3ba2 278 (initialize-slots i)
279 (setf (slot-value i 'initializedp) t)
19531fbd 280 i))
281
282
8e6e6b56
DC
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
290
19531fbd 291
292
293
579597e3 294(defmethod call-component :before ((from standard-component) (to mewa))
295 (unless (slot-value to 'initializedp)
296 (initialize-slots to))
297 (setf (slot-value to 'initializedp) t)
298 (setf (slots to) (mapcar #'(lambda (x) (prog2
299 (setf (component.place x) (component.place from))
300 x))
9d6c69fb 301 (slots to))))
579597e3 302
303(defmacro call-presentation (object &rest args)
ae09804a 304 `(present-object ,object :presentation (make-presentation ,object ,@args)))
305
4e2ecf69
DC
306
307(defcomponent about-dialog (option-dialog)
308 ((body :initarg :body)))
309
310(defmethod render-on ((res response) (self about-dialog))
d75822e6
DC
311 (call-next-method)
312 (render-on res (slot-value self 'body)))
4e2ecf69 313
8e6e6b56
DC
314
315(defmethod instance-is-stored-p ((instance clsql:standard-db-object))
316 (slot-value instance 'clsql-sys::view-database))
317
ae09804a 318(defaction cancel-save-instance ((self mewa))
1679abef 319 (cond
8e6e6b56 320 ((instance-is-stored-p (instance self))
1679abef 321 (meta-model::update-instance-from-records (instance self))
322 (answer self))
323 (t (answer nil))))
ae09804a 324
325(defaction save-instance ((self mewa))
7129498f 326 (meta-model:sync-instance (instance self))
8e6e6b56
DC
327 (setf (modifiedp self) nil)
328 (answer self))
ae09804a 329
330
12dcf3d4 331(defaction ensure-instance-sync ((self mewa))
ae09804a 332 (when (modifiedp self)
8e6e6b56 333 (let ((message (format nil "Record has been modified, Do you wish to save the changes?")))
4e2ecf69
DC
334 (case (call 'about-dialog
335 :body (make-presentation (instance self)
336 :type :viewer)
ae09804a 337 :message message
338 :options '((:save . "Save changes to Database")
339 (:cancel . "Cancel all changes")))
340 (:cancel
341 (cancel-save-instance self))
342 (:save
12dcf3d4 343 (save-instance self))))))
ae09804a 344
e8e743d7 345(defaction ok ((self mewa) &optional arg)
346 "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
347 (declare (ignore arg))
348 (ensure-instance-sync self)
349 (answer self))
350
ae09804a 351(defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
352 (let* ((old (prog1
353 (presentation-slot-value slot instance)
354 (call-next-method)))
355 (new (presentation-slot-value slot instance)))
356
357 (unless (equal new old )
358 (let ((self (ucw::parent slot)))
359 (setf (modifiedp self) instance
4e2ecf69 360 (modifications self) (append (list new old value slot instance) (modifications self)))))))
233380f7 361
ab7ef8e9
DC
362;;;; * Finally set up some defaults
363
364(setf (find-attribute t :viewer)
365 '(mewa-object-presentation :global-properties (:editablep nil))
366 (find-attribute t :editor)
367 '(mewa-object-presentation :global-properties (:editablep t))
368 (find-attribute t :one-line)
369 '(mewa::mewa-one-line-presentation)
370 (find-attribute t :listing)
371 '(mewa::mewa-list-presentation :global-properties (:editablep nil) :editablep t)
372 (find-attribute t :search-presentation)
373 '(mewa-object-presentation))
374
375
376
377
233380f7 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.