fixed autocomplete to be more specific
[clinton/lisp-on-lines.git] / src / mewa.lisp
1 (declaim (optimize (speed 2) (space 3) (safety 0)))
2
3 (in-package :lisp-on-lines)
4
5 (defparameter *default-type* :ucw)
6
7 ;;;; I think these are unused now
8 (defmethod perform-set-attributes ((occurence-name t) definitions)
9 (dolist (def definitions)
10 (funcall #'set-attribute occurence-name (first def) (rest def))))
11
12 (defmethod perform-set-attribute-properties ((occurence-name t) definitions)
13 (dolist (def definitions)
14 (funcall #'set-attribute-properties occurence-name (car def) (cdr def))))
15
16 ;;;; PLIST Utilities.
17
18 (defun plist-nunion (new-props plist)
19 "Destructive Merge of plists. PLIST is modified and returned.
20 NEW-PROPS is merged into PLIST such that any properties
21 in both PLIST and NEW-PROPS get the value in NEW-PROPS.
22 The other properties in PLIST are left untouched."
23 (loop for cons on new-props by #'cddr
24 do (setf (getf plist (first cons)) (second cons))
25 finally (return plist)))
26
27 (defun plist-union (new-props plist)
28 "Non-destructive version of plist-nunion"
29 (plist-nunion new-props (copy-list plist)))
30
31
32 ;;;; * Occurences
33
34 (defvar *occurence-map* (make-hash-table)
35 "Presentations are created by associating an 'occurence'
36 with an instance of a class. This is usually keyed off class-name,
37 although an arbitrary occurence can be used with an arbitrary class.")
38
39 (define-layered-class
40 standard-occurence ()
41 ((attribute-map :accessor attribute-map :initform (make-hash-table)))
42 (:documentation
43 "an occurence holds the attributes like a class holds slot-definitions.
44 Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."))
45
46 (defun find-or-create-occurence (name)
47 "Returns the occurence associated with this name."
48 (let ((occurence (gethash name *occurence-map*)))
49 (if occurence
50 occurence
51 (let ((new-occurence (make-instance 'standard-occurence)))
52 (setf (gethash name *occurence-map*) new-occurence)
53 new-occurence))))
54
55 (defun clear-occurence (occurence)
56 "removes all attributes from the occurence"
57 (setf (attribute-map occurence) (make-hash-table)))
58
59 (defgeneric find-occurence (name)
60 (:method ((name symbol))
61 (find-or-create-occurence name))
62 (:method (instance)
63 (find-or-create-occurence (class-name (class-of instance)))))
64
65
66 ;;;; * Attributes
67
68 (define-layered-class
69 standard-attribute ()
70 ((name :layered-accessor attribute.name :initarg :name :initform "attribute")
71 (type :layered-accessor attribute.type :initarg :type :initform t :type symbol)
72 (plist :layered-accessor attribute.plist :initarg :plist :initform nil))
73 (:documentation "Attributes are used to display a part of a thing, such as a slot of an object, a text label, the car of a list, etc."))
74
75
76 (defmethod print-object ((self standard-attribute) stream)
77 (print-unreadable-object (self stream :type t)
78 (with-slots (name type) self
79 (format stream "~A ~A" name type))))
80
81 (define-layered-class
82 presentation-attribute (standard-attribute)
83 ()
84 (:documentation "Presentation Attributes are used to display objects
85 using the attributes defined in an occurence. Presentation Attributes are always named using keywords."))
86
87 (defun clear-attributes (name)
88 "removes all attributes from an occurance"
89 (clear-occurence (find-occurence name)))
90
91 (defmethod find-attribute-class-for-name (name)
92 "presentation attributes are named using keywords"
93 (if (keywordp name)
94 'presentation-attribute
95 'standard-attribute))
96
97 (defmethod ensure-attribute ((occurence standard-occurence) name type plist)
98 "Creates an attribute in the given occurence"
99 (setf (gethash name (attribute-map occurence))
100 (make-instance (find-attribute-class-for-name name)
101 :name name :type type :plist plist)))
102
103 (defmethod find-attribute ((occurence standard-occurence) name)
104 (gethash name (attribute-map occurence)))
105
106 (defmethod find-all-attributes ((occurence standard-occurence))
107 (loop for att being the hash-values of (attribute-map occurence)
108 collect att))
109
110 (defmethod ensure-attribute (occurence-name name type plist)
111 (ensure-attribute
112 (find-occurence occurence-name)
113 name
114 type
115 plist))
116
117 ;;;; The following functions make up the public interface to the
118 ;;;; MEWA Attribute Occurence system.
119
120 (defmethod find-all-attributes (occurence-name)
121 (find-all-attributes (find-occurence occurence-name)))
122
123 (defmethod find-attribute (occurence-name attribute-name)
124 "Returns the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name"
125 (find-attribute (find-occurence occurence-name) attribute-name))
126
127 (defmethod (setf find-attribute) ((def list) occurence-name attribute-name)
128 (ensure-attribute occurence-name attribute-name (first def) (rest def)))
129
130 (defmethod set-attribute (occurence-name attribute-name definition &key (inherit t))
131 (let ((att (find-attribute occurence-name attribute-name)))
132 (setf (find-attribute occurence-name attribute-name)
133 (if (and att inherit)
134 (cons (car definition)
135 (plist-union (cdr definition)
136 (attribute.plist att)))
137 definition))))
138
139 (defmethod set-attribute-properties ((occurence-name t) attribute properties)
140 (let ((a (find-attribute occurence-name attribute)))
141 (if a
142 (setf (attribute.plist a) (plist-nunion properties (attribute.plist a)))
143 (error "Attribute ~A does not exist" attribute))))
144
145 (defmethod perform-define-attributes ((occurence-name t) attributes)
146 (loop for attribute in attributes
147 do (destructuring-bind (name type &rest args)
148 attribute
149 (cond ((eq type t)
150 ;;use the existing (default) type
151 (set-attribute-properties occurence-name name args))
152 ((not (null type))
153 ;;set the type as well
154 (set-attribute occurence-name name (cons type args)))))))
155
156 (defmacro define-attributes (occurence-names &body attribute-definitions)
157 `(progn
158 ,@(loop for occurence-name in occurence-names
159 collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions)))))
160
161
162 (defmethod setter (attribute)
163 (let ((setter (getf (attribute.plist attribute) :setter))
164 (slot-name (getf (attribute.plist attribute) :slot-name)))
165 (cond (setter
166 setter)
167 (slot-name
168 #'(lambda (value object)
169 (setf (slot-value object slot-name) value)))
170 (t
171 #'(lambda (value object)
172 (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute))))))
173
174 (defmethod getter (attribute)
175 (let ((getter (getf (attribute.plist attribute) :getter))
176 (slot-name (getf (attribute.plist attribute) :slot-name)))
177 (cond (getter
178 getter)
179 (slot-name
180 #'(lambda (object)
181 (when (slot-boundp object slot-name)
182 (slot-value object slot-name)))))))
183
184 (defgeneric attribute-value (instance attribute)
185 (:method (instance (attribute standard-attribute))
186 (funcall (getter attribute) instance)))
187
188 (defgeneric (setf attribute-value) (value instance attribute)
189 (:method (value instance (attribute standard-attribute))
190 (funcall (setter attribute) value instance)))
191
192
193 ;;;; ** Default Attributes
194
195
196 ;;;; The default mewa class contains the types use as defaults.
197 ;;;; maps meta-model slot-types to slot-presentation
198
199 (defvar *default-attributes-class-name* 'default)
200
201 (defmacro with-default-attributes ((occurence-name) &body body)
202 `(let ((*default-attributes-class-name* ',occurence-name))
203 ,@body))
204
205 (define-attributes (default)
206 (boolean mewa-boolean)
207 (string mewa-string)
208 (number mewa-currency)
209 (integer mewa-integer)
210 (currency mewa-currency)
211 (clsql:generalized-boolean mewa-boolean)
212 (foreign-key foreign-key)
213 (:viewer mewa-viewer)
214 (:editor mewa-editor)
215 (:creator mewa-creator)
216 (:as-string mewa-one-line-presentation)
217 (:one-line mewa-one-line-presentation)
218 (:listing mewa-list-presentation :global-properties (:editablep nil) :editablep t)
219 (:search-model mewa-object-presentation))
220
221 (defun find-presentation-attributes (occurence-name)
222 (loop for att in (find-all-attributes occurence-name)
223 when (typep att 'presentation-attribute)
224 collect att))
225
226 (defun attribute-to-definition (attribute)
227 (nconc (list (attribute.name attribute)
228 (attribute.type attribute))
229 (attribute.plist attribute)))
230
231 (defun find-default-presentation-attribute-definitions ()
232 (if (eql *default-attributes-class-name* 'default)
233 (mapcar #'attribute-to-definition (find-presentation-attributes 'default))
234 (remove-duplicates (mapcar #'attribute-to-definition
235 (append
236 (find-presentation-attributes 'default)
237 (find-presentation-attributes
238 *default-attributes-class-name*))))))
239 (defun gen-ptype (type)
240 (let* ((type (if (consp type) (car type) type))
241 (possible-default (find-attribute *default-attributes-class-name* type))
242 (real-default (find-attribute 'default type)))
243 (cond
244 (possible-default
245 (attribute.type possible-default))
246 (real-default
247 (attribute.type real-default))
248 (t type))))
249
250 (defun gen-presentation-slots (instance)
251 (mapcar #'(lambda (x) (gen-pslot (cadr x)
252 (string (car x))
253 (car x)))
254 (meta-model:list-slot-types instance)))
255
256
257 (defun gen-pslot (type label slot-name)
258 (copy-list `(,(gen-ptype type)
259 :label ,label
260 :slot-name ,slot-name)))
261
262 (defmethod find-default-attributes ((model t))
263 "return the default attributes for a given model using the meta-model's meta-data"
264 (append (mapcar #'(lambda (s)
265 (cons (car s)
266 (gen-pslot
267 (if (meta-model:foreign-key-p model (car s))
268 'foreign-key
269 (cadr s))
270 (string (car s)) (car s))))
271 (meta-model:list-slot-types model))
272 (mapcar #'(lambda (s)
273 (cons s (append (gen-pslot 'has-many (string s) s)
274 `(:presentation
275 (make-presentation
276 ,model
277 :type :one-line)))))
278 (meta-model:list-has-many model))
279 (find-default-presentation-attribute-definitions)))
280
281 (defmethod set-default-attributes ((model t))
282 "Set the default attributes for MODEL"
283 (clear-attributes model)
284 (mapcar #'(lambda (x)
285 (setf (find-attribute model (car x)) (cdr x)))
286 (find-default-attributes model)))
287
288 ;;;presentations
289 (defcomponent mewa ()
290 ((instance :accessor instance :initarg :instance)
291 (attributes
292 :initarg :attributes
293 :accessor attributes
294 :initform nil)
295 (attributes-getter
296 :accessor attributes-getter
297 :initform #'get-attributes
298 :initarg :attributes-getter)
299 (attribute-slot-map
300 :accessor attribute-slot-map
301 :initform nil)
302 (global-properties
303 :initarg :global-properties
304 :accessor global-properties
305 :initform nil)
306 (classes
307 :initarg :classes
308 :accessor classes
309 :initform nil)
310 (use-instance-class-p
311 :initarg :use-instance-class-p
312 :accessor use-instance-class-p
313 :initform t)
314 (initializedp :initform nil)
315 (modifiedp :accessor modifiedp :initform nil :initarg :modifiedp)
316 (modifications :accessor modifications :initform nil)))
317
318
319 (defmethod attributes :around ((self mewa))
320 (let ((a (call-next-method)))
321 (or a (funcall (attributes-getter self) self))))
322
323 (defgeneric get-attributes (mewa))
324
325 (defmethod get-attributes ((self mewa))
326 (if (instance self)
327 (append (meta-model:list-slots (instance self))
328 (meta-model:list-has-many (instance self)))
329 nil))
330
331 (defmethod find-instance-classes ((self mewa))
332 (mapcar #'class-name
333 (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
334
335 (defun make-attribute (&rest props &key type &allow-other-keys)
336 (remf props :type)
337 (cons (gensym) (cons type props)))
338
339 (defun make-presentation-for-attribute-list-item
340 (occurence att-name plist parent-presentation &optional type)
341 (declare (type list plist) (type symbol att-name))
342 "This is a ucw specific function that will eventually be factored elsewhere."
343 (let* ((attribute (find-attribute occurence att-name))
344 (type (when attribute (or type (attribute.type attribute))))
345 (class-name
346 (or (gethash (if (consp type)
347 (car type)
348 type)
349 *presentation-slot-type-mapping*)
350 (error "Can't find slot type for ~A in ~A from ~A" att-name occurence parent-presentation))))
351
352 (cons (attribute.name attribute) (apply #'make-instance
353 class-name
354 (append (plist-nunion
355 plist
356 (plist-union
357 (global-properties parent-presentation)
358 (attribute.plist attribute)))
359 (list :size 30 :parent parent-presentation))))))
360
361 (defmethod find-applicable-attributes-using-attribute-list (occurence attribute-list)
362 "Returns a list of functions that, when called with an object presentation,
363 returns the ucw slot presentation that will be used to present this attribute
364 in that object presentation."
365 (loop for att in attribute-list
366 with funs = (list)
367 do (let ((att att)) (cond
368 ;;simple casee
369 ((symbolp att)
370 (push #'(lambda (p)
371 (make-presentation-for-attribute-list-item occurence att nil p))
372 funs))
373 ;;if the car is a keyword then this is an inline def
374 ;; drewc nov 12 2005:
375 ;; i never used this, and never told anybody about it.
376 ;; removing it.
377 #+ (or) ((and (listp x) (keywordp (car x)))
378 (let ((att (apply #'make-attribute x)))
379 (setf (cddr att)
380 (plist-union (cddr att) (global-properties self)))
381 att))
382
383 ;; if the plist has a :type
384 ((and (listp att) (getf (cdr att) :type))
385 (let ((type (getf (cdr att) :type)))
386 (push #'(lambda (p)
387 (make-presentation-for-attribute-list-item
388 occurence (first att)
389 (cdr att)
390 p
391 type))
392 funs)))
393 ;;finally if we are just overiding the props
394 ((and (listp att) (symbolp (car att)))
395 (push #'(lambda (p)
396 (make-presentation-for-attribute-list-item occurence (first att) (rest att) p))
397 funs))))
398 finally (return (nreverse funs))))
399
400
401 (defun find-attribute-names (mewa)
402 (mapcar #'(lambda (x)
403 (if (listp x)
404 (first x)
405 x))
406 (attributes mewa)))
407
408 (defmethod find-applicable-attributes ((self mewa))
409 (if (attributes self)
410 (find-applicable-attributes-using-attribute-list (instance self) (attributes self))
411 (find-applicable-attributes-using-attribute-list (instance (get-attributes self)))))
412
413
414 (defmethod find-slot-presentations ((self mewa))
415 (mapcar #'(lambda (a) (funcall a self))
416 (find-applicable-attributes self)))
417
418 (defmethod find-attribute-slot ((self mewa) (attribute symbol))
419 (cdr (assoc attribute (attribute-slot-map self))))
420
421 (defmethod initialize-slots ((self mewa))
422 (when (instance self)
423 (when (use-instance-class-p self)
424 (setf (classes self)
425 (append (find-instance-classes self)
426 (classes self))))
427 (setf (attribute-slot-map self) (find-slot-presentations self))
428 (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self )))))
429
430
431 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
432 ;(warn "Initargs : ~A" initargs)
433 (let* ((a (find-attribute object type))
434 (i (apply #'make-instance
435 (if a
436 (attribute.type a)
437 type)
438 (plist-union initargs (when a
439 (attribute.plist a))))))
440
441 (setf (slot-value i 'instance) object)
442 (initialize-slots i)
443 (setf (slot-value i 'initializedp) t)
444 i))
445
446 (defmethod make-presentation ((list list) &key (type :listing) (initargs nil))
447 (let ((args (append
448 `(:type ,type)
449 `(:initargs
450 (:instances ,list
451 ,@initargs)))))
452
453 (apply #'make-presentation (car list) args)))
454
455 (defmethod initialize-slots-place ((place ucw::place) (mewa mewa))
456 (setf (slots mewa) (mapcar #'(lambda (x)
457 (prog1 x
458 (setf (component.place x) place)))
459 (slots mewa))))
460
461 (arnesi:defmethod/cc call-component :before ((from standard-component) (to mewa))
462 (unless (slot-value to 'initializedp)
463 (initialize-slots to))
464 (setf (slot-value to 'initializedp) t)
465 (initialize-slots-place (component.place from) to)
466 to)
467
468
469
470 (defmacro call-presentation (object &rest args)
471 `(present-object ,object :presentation (make-presentation ,object ,@args)))
472
473
474 (defcomponent about-dialog (option-dialog)
475 ((body :initarg :body)))
476
477 (defmethod render-on ((res response) (self about-dialog))
478 (call-next-method)
479 (render-on res (slot-value self 'body)))
480
481
482
483
484 (defaction cancel-save-instance ((self mewa))
485 (cond
486 ((meta-model::persistentp (instance self))
487 (meta-model::update-instance-from-records (instance self))
488 (answer self))
489 (t (answer nil))))
490
491 (defaction save-instance ((self mewa))
492 (meta-model:sync-instance (instance self))
493 (setf (modifiedp self) nil)
494 (answer self))
495
496 (defmethod confirm-sync-instance ((self mewa))
497 nil)
498
499 (defaction ensure-instance-sync ((self mewa))
500 (when (modifiedp self)
501 (if nil
502 (let ((message (format nil "Record has been modified, Do you wish to save the changes?")))
503 (case (call 'about-dialog
504 :body (make-presentation (instance self)
505 :type :viewer)
506 :message message
507 :options '((:save . "Save changes to Database")
508 (:cancel . "Cancel all changes")))
509 (:cancel
510 (cancel-save-instance self))
511 (:save
512 (save-instance self))))
513 (save-instance self))))
514
515 (defaction sync-and-answer ((self mewa))
516 (ensure-instance-sync self)
517 (answer (instance self)))
518
519 (defaction ok ((self mewa) &optional arg)
520 "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
521 ;(declare (ignore arg))
522 (sync-and-answer self))
523
524 (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
525 (let* ((old (prog1
526 (presentation-slot-value slot instance)
527 (call-next-method)))
528 (new (presentation-slot-value slot instance)))
529
530 (unless (equal new old )
531 (let ((self (ucw::parent slot)))
532 (setf (modifiedp self) instance
533 (modifications self) (append (list new old value slot instance) (modifications self)))))))
534
535
536
537
538
539
540
541 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
542 ;; You are granted the rights to distribute
543 ;; and use this software as governed by the terms
544 ;; of the Lisp Lesser GNU Public License
545 ;; (http://opensource.franz.com/preamble.html),
546 ;; known as the LLGPL.