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