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