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