major update to slot presentations
[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)
569ad9e6
DC
152 (attribute-slot-map
153 :accessor attribute-slot-map
154 :initform nil)
579597e3 155 (global-properties
156 :initarg :global-properties
157 :accessor global-properties
158 :initform nil)
159 (classes
160 :initarg :classes
161 :accessor classes
162 :initform nil)
163 (use-instance-class-p
164 :initarg :use-instance-class-p
165 :accessor use-instance-class-p
166 :initform t)
167 (initializedp :initform nil)
8e6e6b56 168 (modifiedp :accessor modifiedp :initform nil :initarg :modifiedp)
d1bb68e0 169 (modifications :accessor modifications :initform nil)))
579597e3 170
579597e3 171
172(defmethod attributes :around ((self mewa))
173 (let ((a (call-next-method)))
174 (or a (funcall (attributes-getter self) self))))
175
19531fbd 176(defgeneric get-attributes (mewa))
177
579597e3 178(defmethod get-attributes ((self mewa))
179 (if (instance self)
180 (append (meta-model:list-slots (instance self))
181 (meta-model:list-has-many (instance self)))
182 nil))
183
579597e3 184(defmethod find-instance-classes ((self mewa))
185 (mapcar #'class-name
186 (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
187
188(defmethod find-all-attributes ((self mewa))
189 (reduce #'append
190 (mapcar #'(lambda (x)
191 (cdr (find-class-attributes x)))
192 (classes self))))
193
194(defun make-attribute (&rest props &key type &allow-other-keys)
195 (remf props :type)
196 (cons (gensym) (cons type props)))
197
198
199(defmethod find-applicable-attributes ((self mewa))
200 (let ((all-attributes (find-all-attributes self)))
201 (flet ((gen-att (x) (let ((att (assoc x all-attributes)))
202 (when att
203 (setf (cddr att) (plist-union (global-properties self) (cddr att)))
204 att))))
205 (if (attributes self)
206 (remove 'nil
207 (mapcar #'(lambda (x)
208 (cond
209 ;;simple casee
210 ((symbolp x)
211 (gen-att x))
212 ;;if the car is a keyword then this is an inline def
213 ((and (listp x) (keywordp (car x)))
214 (let ((att (apply #'make-attribute x)))
215 (setf (cddr att)
216 (plist-union (cddr att) (global-properties self)))
217 att))
218 ;; if the plist has a :type
219 ((and (listp x) (getf (cdr x) :type))
220 (let ((new (cdr (apply #'make-attribute (cdr x))))
221 (def (gen-att (car x))))
222 (setf (cdr new) (plist-union (cdr new) (cddr def)))
223 (cons (car def) new)))
224 ;;finally if we are just overiding the props
225 ((and (listp x) (symbolp (car x)))
226 (let ((new (cdr (apply #'make-attribute (cdr x))))
227 (def (gen-att (car x))))
228 (setf (cdr new) (plist-union (cdr new) (cddr def)))
229 (cons (car def) (cons (second def) (cdr new)))))
230
231 )
232 )
233
234 (attributes self)))
235 all-attributes))))
236
569ad9e6
DC
237(defmethod find-slot-presentation-for-attribute ((self mewa) attribute)
238 (let ((class-name
239 (or (gethash (second attribute) ucw::*slot-type-mapping*)
240 (error "Can't find slot type for ~A" (second attribute)))))
241
242 (cons (first attribute) (apply #'make-instance
243 class-name
244 (append (cddr attribute) (list :parent self :size 30))))))
245
579597e3 246(defmethod find-slot-presentations ((self mewa))
569ad9e6 247 (mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a))
579597e3 248 (find-applicable-attributes self)))
249
569ad9e6
DC
250(defmethod find-attribute-slot ((self mewa) (attribute symbol))
251 (cdr (assoc attribute (attribute-slot-map self))))
579597e3 252
253(defmethod initialize-slots ((self mewa))
254 (when (use-instance-class-p self)
255 (setf (classes self)
256 (append (find-instance-classes self)
257 (classes self))))
569ad9e6
DC
258 (setf (attribute-slot-map self) (find-slot-presentations self))
259 (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self ))))
579597e3 260
261
579597e3 262(defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
263 (let* ((p (make-instance 'mewa-object-presentation))
264 (a (progn (setf (slot-value p 'instance) object)
265 (initialize-slots p)
266 (assoc type (find-all-attributes p))))
267
268 (i (apply #'make-instance (second a) (plist-union initargs (cddr a)))))
269 (setf (slot-value i 'instance) object)
270 i))
271
19531fbd 272(defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
273 (let* ((p (make-instance 'mewa-object-presentation))
274 (a (progn (setf (slot-value p 'instance) object)
275 (initialize-slots p)
276 (assoc type (find-all-attributes p))))
277
278 (i (apply #'make-instance (or (second a)
279 ;; if we didnt find the type,
280 ;; use the symbol as a class.
281 (if (eql (symbol-package type)
282 (find-package 'keyword))
283 (symbol-name type)
284 type))
285 (plist-union initargs (cddr a)))))
286 (setf (slot-value i 'instance) object)
2acd3ba2 287 (initialize-slots i)
288 (setf (slot-value i 'initializedp) t)
19531fbd 289 i))
290
291
8e6e6b56
DC
292(defmethod initialize-slots-place ((place ucw::place) (mewa mewa))
293 (setf (slots mewa) (mapcar #'(lambda (x)
294 (prog1 x
295 (setf (component.place x) place)))
296 (slots mewa))))
297
579597e3 298(defmethod call-component :before ((from standard-component) (to mewa))
299 (unless (slot-value to 'initializedp)
300 (initialize-slots to))
301 (setf (slot-value to 'initializedp) t)
302 (setf (slots to) (mapcar #'(lambda (x) (prog2
303 (setf (component.place x) (component.place from))
304 x))
9d6c69fb 305 (slots to))))
579597e3 306
307(defmacro call-presentation (object &rest args)
ae09804a 308 `(present-object ,object :presentation (make-presentation ,object ,@args)))
309
4e2ecf69
DC
310
311(defcomponent about-dialog (option-dialog)
312 ((body :initarg :body)))
313
314(defmethod render-on ((res response) (self about-dialog))
d75822e6
DC
315 (call-next-method)
316 (render-on res (slot-value self 'body)))
4e2ecf69 317
8e6e6b56
DC
318
319(defmethod instance-is-stored-p ((instance clsql:standard-db-object))
569ad9e6
DC
320 (slot-value instance 'clsql-sys::view-database))
321
322(defmethod instance-is-stored-p ((mewa mewa))
323 (instance-is-stored-p (instance mewa)))
8e6e6b56 324
ae09804a 325(defaction cancel-save-instance ((self mewa))
1679abef 326 (cond
8e6e6b56 327 ((instance-is-stored-p (instance self))
1679abef 328 (meta-model::update-instance-from-records (instance self))
329 (answer self))
330 (t (answer nil))))
ae09804a 331
332(defaction save-instance ((self mewa))
7129498f 333 (meta-model:sync-instance (instance self))
8e6e6b56
DC
334 (setf (modifiedp self) nil)
335 (answer self))
ae09804a 336
337
12dcf3d4 338(defaction ensure-instance-sync ((self mewa))
ae09804a 339 (when (modifiedp self)
8e6e6b56 340 (let ((message (format nil "Record has been modified, Do you wish to save the changes?")))
4e2ecf69
DC
341 (case (call 'about-dialog
342 :body (make-presentation (instance self)
343 :type :viewer)
ae09804a 344 :message message
345 :options '((:save . "Save changes to Database")
346 (:cancel . "Cancel all changes")))
347 (:cancel
348 (cancel-save-instance self))
349 (:save
12dcf3d4 350 (save-instance self))))))
ae09804a 351
e8e743d7 352(defaction ok ((self mewa) &optional arg)
353 "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
354 (declare (ignore arg))
355 (ensure-instance-sync self)
356 (answer self))
357
ae09804a 358(defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
359 (let* ((old (prog1
360 (presentation-slot-value slot instance)
361 (call-next-method)))
362 (new (presentation-slot-value slot instance)))
363
364 (unless (equal new old )
365 (let ((self (ucw::parent slot)))
366 (setf (modifiedp self) instance
4e2ecf69 367 (modifications self) (append (list new old value slot instance) (modifications self)))))))
233380f7 368
ab7ef8e9
DC
369;;;; * Finally set up some defaults
370
371(setf (find-attribute t :viewer)
372 '(mewa-object-presentation :global-properties (:editablep nil))
373 (find-attribute t :editor)
374 '(mewa-object-presentation :global-properties (:editablep t))
375 (find-attribute t :one-line)
376 '(mewa::mewa-one-line-presentation)
377 (find-attribute t :listing)
378 '(mewa::mewa-list-presentation :global-properties (:editablep nil) :editablep t)
379 (find-attribute t :search-presentation)
380 '(mewa-object-presentation))
381
382
383
384
233380f7 385
386;; This software is Copyright (c) Drew Crampsie, 2004-2005.
387;; You are granted the rights to distribute
388;; and use this software as governed by the terms
389;; of the Lisp Lesser GNU Public License
390;; (http://opensource.franz.com/preamble.html),
391;; known as the LLGPL.