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