2 (:use
:ucw
:common-lisp
)
3 (:export
:mewa
:mewa-object-presentation
:mewa-one-line-presentation
:find-attribute
:set-default-attributes
:make-presentation
:call-presentation
:label
:set-attribute
:find-class-attributes
))
7 (defparameter *default-type
* :ucw
)
9 ;;; maps meta-model slot-types to slot-presentation
10 (defparameter *slot-type-map
* '(number ucw
:currency
))
12 ;;; an alist of model-class-name . attributes
13 ;;; should really be a hash-table.
14 (defvar *attribute-map
* (list))
16 ;;; some utilities for merging plists
18 (defun plist-nunion (new-props plist
)
19 (loop for cons on new-props
20 for i from
1 to
(length new-props
)
22 do
(setf (getf plist
(first cons
)) (second cons
))
23 finally
(return plist
)))
25 (defun plist-union (new-props plist
)
26 "Non-destructive version of plist-nunion"
27 (plist-nunion new-props
(copy-list plist
)))
29 (defun gen-ptype (type)
30 (or (getf *slot-type-map
* type
) type
))
32 (defun gen-presentation-slots (instance)
33 (mapcar #'(lambda (x) (gen-pslot (cadr x
)
36 (list-slot-types instance
)))
39 (defun gen-pslot (type label slot-name
)
40 (copy-list `(,(gen-ptype type
)
42 :slot-name
,slot-name
)))
44 (defun gen-presentation-args (instance args
)
45 (declare (ignore instance
))
49 (defun find-or-create-attributes (class-name)
50 "return an exisiting class attribute map or create one.
52 A map is a cons of class-name . attributes.
53 attributes is an alist keyed on the attribute nreeame."
54 (or (assoc class-name
*attribute-map
*)
56 (setf *attribute-map
* (acons class-name
(list (list)) *attribute-map
*))
57 (assoc class-name
*attribute-map
*))))
59 (defgeneric find-class-attributes
(class))
61 (defmethod find-class-attributes ((model t
))
62 (find-or-create-attributes (class-name (class-of model
))))
64 (defmethod find-class-attributes ((model symbol
))
65 (find-or-create-attributes model
))
67 (defmethod add-attribute ((model t
) name def
)
68 (let ((map (find-class-attributes model
)))
69 (setf (cdr map
) (acons name def
(cdr map
)))))
71 (defmethod find-attribute ((model t
) name
)
72 (assoc name
(cdr (find-class-attributes model
))))
74 (defmethod (setf find-attribute
) ((def list
) (model t
) name
)
75 (let ((attr (find-attribute model name
)))
81 (add-attribute model name def
)
82 (find-attribute model name
)))))
84 (defmethod set-attribute ((model t
) name definition
&key
(inherit t
))
85 (setf (find-attribute model name
)
87 (cons (car definition
)
88 (plist-union (cdr definition
)
89 (cddr (find-attribute model name
))))
93 (defgeneric attributes-getter
(model))
101 :accessor attributes-getter
102 :initform
#'get-attributes
103 :initarg
:attributes-getter
)
105 :initarg
:global-properties
106 :accessor global-properties
112 (use-instance-class-p
113 :initarg
:use-instance-class-p
114 :accessor use-instance-class-p
116 (initializedp :initform nil
)
117 (modifiedp :accessor modifiedp
:initform nil
)))
119 (defcomponent mewa-object-presentation
(mewa object-presentation
) ())
121 (defcomponent mewa-one-line-presentation
(mewa one-line-presentation
)
123 (:default-initargs
:attributes-getter
#'one-line-attributes-getter
))
125 (defmethod attributes :around
((self mewa
))
126 (let ((a (call-next-method)))
127 (or a
(funcall (attributes-getter self
) self
))))
129 (defmethod get-attributes ((self mewa
))
131 (append (meta-model:list-slots
(instance self
))
132 (meta-model:list-has-many
(instance self
)))
135 (defmethod one-line-attributes-getter ((self mewa
))
136 (or (meta-model:list-keys
(instance self
))))
140 (defmethod find-instance-classes ((self mewa
))
142 (it.bese.arnesi.mopp
:compute-class-precedence-list
(class-of (instance self
)))))
144 (defmethod find-all-attributes ((self mewa
))
146 (mapcar #'(lambda (x)
147 (cdr (find-class-attributes x
)))
150 (defun make-attribute (&rest props
&key type
&allow-other-keys
)
152 (cons (gensym) (cons type props
)))
155 (defmethod find-applicable-attributes ((self mewa
))
156 (let ((all-attributes (find-all-attributes self
)))
157 (flet ((gen-att (x) (let ((att (assoc x all-attributes
)))
159 (setf (cddr att
) (plist-union (global-properties self
) (cddr att
)))
161 (if (attributes self
)
163 (mapcar #'(lambda (x)
168 ;;if the car is a keyword then this is an inline def
169 ((and (listp x
) (keywordp (car x
)))
170 (let ((att (apply #'make-attribute x
)))
172 (plist-union (cddr att
) (global-properties self
)))
174 ;; if the plist has a :type
175 ((and (listp x
) (getf (cdr x
) :type
))
176 (let ((new (cdr (apply #'make-attribute
(cdr x
))))
177 (def (gen-att (car x
))))
178 (setf (cdr new
) (plist-union (cdr new
) (cddr def
)))
179 (cons (car def
) new
)))
180 ;;finally if we are just overiding the props
181 ((and (listp x
) (symbolp (car x
)))
182 (let ((new (cdr (apply #'make-attribute
(cdr x
))))
183 (def (gen-att (car x
))))
184 (setf (cdr new
) (plist-union (cdr new
) (cddr def
)))
185 (cons (car def
) (cons (second def
) (cdr new
)))))
193 (defmethod find-slot-presentations ((self mewa
))
194 (mapcar #'(lambda (s)
195 (let ((class-name (or (gethash (second s
) ucw
::*slot-type-mapping
*) 'mewa-object-presentation
)))
196 (apply #'make-instance
198 (append (cddr s
) (list :parent self
)))))
199 (find-applicable-attributes self
)))
201 (defmethod default-attributes ((model t
))
202 (append (mapcar #'(lambda (s) (cons (car s
) (gen-pslot (if (meta-model:foreign-key-p model
(car s
))
205 (string (car s
)) (car s
))))
206 (meta-model:list-slot-types model
))
207 (mapcar #'(lambda (s) (cons s
(append (gen-pslot 'ucw
::has-many
(string s
) s
) `(:presentation
(make-presentation ,model
:type
:one-line
)))))
208 (meta-model:list-has-many model
))))
210 (defmethod set-default-attributes ((model t
))
211 (mapcar #'(lambda (x)
212 (setf (find-attribute model
(car x
)) (cdr x
)))
213 (default-attributes model
)))
216 (defcomponent mewa-object-presentation
(mewa ucw
:object-presentation
) ())
218 (defcomponent mewa-list-presentation
(mewa ucw
:list-presentation
)
219 ((it.bese.ucw
::instances
:accessor instances
:initarg
:instances
:initform nil
)
220 (instance :accessor instance
))) ;to make make-presentation happy
222 (defmethod get-all-instances ((self mewa-list-presentation
))
228 (defmethod initialize-slots ((self mewa
))
229 (when (use-instance-class-p self
)
231 (append (find-instance-classes self
)
233 (setf (slots self
) (find-slot-presentations self
)))
236 (defmethod render-on :around
((res response
) (self mewa
))
237 (unless (slot-value self
'initializedp
)
238 (initialize-slots self
))
239 (setf (slot-value self
'initializedp
) t
)
243 (defmethod make-presentation ((object t
) &key
(type :viewer
) (initargs nil
))
244 (let* ((p (make-instance 'mewa-object-presentation
))
245 (a (progn (setf (slot-value p
'instance
) object
)
247 (assoc type
(find-all-attributes p
))))
249 (i (apply #'make-instance
(second a
) (plist-union initargs
(cddr a
)))))
250 (setf (slot-value i
'instance
) object
)
253 (defmethod call-component :before
((from standard-component
) (to mewa
))
254 (unless (slot-value to
'initializedp
)
255 (initialize-slots to
))
256 (setf (slot-value to
'initializedp
) t
)
257 (setf (slots to
) (mapcar #'(lambda (x) (prog2
258 (setf (component.place x
) (component.place from
))
262 (defmacro call-presentation
(object &rest args
)
263 `(present-object ,object
:presentation
(make-presentation ,object
,@args
)))