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