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