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