changed plist-nunion to get rid of a LENGTH call
[clinton/lisp-on-lines.git] / src / mewa.lisp
1
2
3 (in-package :mewa)
4
5 (defparameter *default-type* :ucw)
6
7 ;;; maps meta-model slot-types to slot-presentation
8 (defparameter *slot-type-map* '(number ucw:currency))
9
10 ;;; an alist of model-class-name . attributes
11 ;;; should really be a hash-table.
12 (defvar *attribute-map* (list))
13
14 ;;; some utilities for merging plists
15
16 (defun plist-nunion (new-props plist)
17 (loop for cons on new-props
18 for i from 1
19 when (oddp i)
20 do (setf (getf plist (first cons)) (second cons))
21 finally (return plist)))
22
23 (defun plist-union (new-props plist)
24 "Non-destructive version of plist-nunion"
25 (plist-nunion new-props (copy-list plist)))
26
27 (defun gen-ptype (type)
28 (or (getf *slot-type-map* type) type))
29
30 (defun gen-presentation-slots (instance)
31 (mapcar #'(lambda (x) (gen-pslot (cadr x)
32 (string (car x))
33 (car x)))
34 (list-slot-types instance)))
35
36
37 (defun gen-pslot (type label slot-name)
38 (copy-list `(,(gen-ptype type)
39 :label ,label
40 :slot-name ,slot-name)))
41
42 (defun gen-presentation-args (instance args)
43 (declare (ignore instance))
44 (if args args nil))
45
46
47 (defun find-or-create-attributes (class-name)
48 "return an exisiting class attribute map or create one.
49
50 A map is a cons of class-name . attributes.
51 attributes is an alist keyed on the attribute nreeame."
52 (or (assoc class-name *attribute-map*)
53 (progn
54 (setf *attribute-map* (acons class-name (list (list)) *attribute-map*))
55 (assoc class-name *attribute-map*))))
56
57 (defgeneric find-class-attributes (class))
58
59 (defmethod find-class-attributes ((model t))
60 (find-or-create-attributes (class-name (class-of model))))
61
62 (defmethod find-class-attributes ((model symbol))
63 (find-or-create-attributes model))
64
65 (defmethod add-attribute ((model t) name def)
66 (let ((map (find-class-attributes model)))
67 (setf (cdr map) (acons name def (cdr map)))))
68
69 (defmethod find-attribute ((model t) name)
70 (assoc name (cdr (find-class-attributes model))))
71
72 (defmethod (setf find-attribute) ((def list) (model t) name)
73 (let ((attr (find-attribute model name)))
74 (if attr
75 (prog2
76 (setf (cdr attr) def)
77 attr)
78 (prog2
79 (add-attribute model name def)
80 (find-attribute model name)))))
81
82 (defmethod set-attribute ((model t) name definition &key (inherit t))
83 (setf (find-attribute model name)
84 (if inherit
85 (cons (car definition)
86 (plist-union (cdr definition)
87 (cddr (find-attribute model name))))
88 definition)))
89
90
91 (defgeneric attributes-getter (model))
92
93 (defcomponent mewa ()
94 ((attributes
95 :initarg :attributes
96 :accessor attributes
97 :initform nil)
98 (attributes-getter
99 :accessor attributes-getter
100 :initform #'get-attributes
101 :initarg :attributes-getter)
102 (global-properties
103 :initarg :global-properties
104 :accessor global-properties
105 :initform nil)
106 (classes
107 :initarg :classes
108 :accessor classes
109 :initform nil)
110 (use-instance-class-p
111 :initarg :use-instance-class-p
112 :accessor use-instance-class-p
113 :initform t)
114 (initializedp :initform nil)
115 (modifiedp :accessor modifiedp :initform nil)))
116
117 (defcomponent mewa-object-presentation (mewa object-presentation) ())
118
119 (defcomponent mewa-one-line-presentation (mewa one-line-presentation)
120 ()
121 (:default-initargs :attributes-getter #'one-line-attributes-getter))
122
123 (defmethod attributes :around ((self mewa))
124 (let ((a (call-next-method)))
125 (or a (funcall (attributes-getter self) self))))
126
127 (defmethod get-attributes ((self mewa))
128 (if (instance self)
129 (append (meta-model:list-slots (instance self))
130 (meta-model:list-has-many (instance self)))
131 nil))
132
133 (defmethod one-line-attributes-getter ((self mewa))
134 (or (meta-model:list-keys (instance self))))
135
136
137
138 (defmethod find-instance-classes ((self mewa))
139 (mapcar #'class-name
140 (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
141
142 (defmethod find-all-attributes ((self mewa))
143 (reduce #'append
144 (mapcar #'(lambda (x)
145 (cdr (find-class-attributes x)))
146 (classes self))))
147
148 (defun make-attribute (&rest props &key type &allow-other-keys)
149 (remf props :type)
150 (cons (gensym) (cons type props)))
151
152
153 (defmethod find-applicable-attributes ((self mewa))
154 (let ((all-attributes (find-all-attributes self)))
155 (flet ((gen-att (x) (let ((att (assoc x all-attributes)))
156 (when att
157 (setf (cddr att) (plist-union (global-properties self) (cddr att)))
158 att))))
159 (if (attributes self)
160 (remove 'nil
161 (mapcar #'(lambda (x)
162 (cond
163 ;;simple casee
164 ((symbolp x)
165 (gen-att x))
166 ;;if the car is a keyword then this is an inline def
167 ((and (listp x) (keywordp (car x)))
168 (let ((att (apply #'make-attribute x)))
169 (setf (cddr att)
170 (plist-union (cddr att) (global-properties self)))
171 att))
172 ;; if the plist has a :type
173 ((and (listp x) (getf (cdr x) :type))
174 (let ((new (cdr (apply #'make-attribute (cdr x))))
175 (def (gen-att (car x))))
176 (setf (cdr new) (plist-union (cdr new) (cddr def)))
177 (cons (car def) new)))
178 ;;finally if we are just overiding the props
179 ((and (listp x) (symbolp (car x)))
180 (let ((new (cdr (apply #'make-attribute (cdr x))))
181 (def (gen-att (car x))))
182 (setf (cdr new) (plist-union (cdr new) (cddr def)))
183 (cons (car def) (cons (second def) (cdr new)))))
184
185 )
186 )
187
188 (attributes self)))
189 all-attributes))))
190
191 (defmethod find-slot-presentations ((self mewa))
192 (mapcar #'(lambda (s)
193 (let ((class-name (or (gethash (second s) ucw::*slot-type-mapping*) 'mewa-object-presentation)))
194 (apply #'make-instance
195 class-name
196 (append (cddr s) (list :parent self)))))
197 (find-applicable-attributes self)))
198
199 (defmethod default-attributes ((model t))
200 (append (mapcar #'(lambda (s) (cons (car s) (gen-pslot (if (meta-model:foreign-key-p model (car s))
201 'ucw::foreign-key
202 (cadr s))
203 (string (car s)) (car s))))
204 (meta-model:list-slot-types model))
205 (mapcar #'(lambda (s) (cons s (append (gen-pslot 'ucw::has-many (string s) s) `(:presentation (make-presentation ,model :type :one-line)))))
206 (meta-model:list-has-many model))))
207
208 (defmethod set-default-attributes ((model t))
209 (mapcar #'(lambda (x)
210 (setf (find-attribute model (car x)) (cdr x)))
211 (default-attributes model)))
212
213
214 (defcomponent mewa-object-presentation (mewa ucw:object-presentation) ())
215
216 (defcomponent mewa-list-presentation (mewa ucw:list-presentation)
217 ((it.bese.ucw::instances :accessor instances :initarg :instances :initform nil)
218 (instance :accessor instance))) ;to make make-presentation happy
219
220 (defmethod get-all-instances ((self mewa-list-presentation))
221 (instances self))
222
223
224
225
226 (defmethod initialize-slots ((self mewa))
227 (when (use-instance-class-p self)
228 (setf (classes self)
229 (append (find-instance-classes self)
230 (classes self))))
231 (setf (slots self) (find-slot-presentations self)))
232
233
234 (defmethod render-on :around ((res response) (self mewa))
235 (unless (slot-value self 'initializedp)
236 (initialize-slots self))
237 (setf (slot-value self 'initializedp) t)
238 (call-next-method))
239
240
241 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
242 (let* ((p (make-instance 'mewa-object-presentation))
243 (a (progn (setf (slot-value p 'instance) object)
244 (initialize-slots p)
245 (assoc type (find-all-attributes p))))
246
247 (i (apply #'make-instance (second a) (plist-union initargs (cddr a)))))
248 (setf (slot-value i 'instance) object)
249 i))
250
251 (defmethod call-component :before ((from standard-component) (to mewa))
252 (unless (slot-value to 'initializedp)
253 (initialize-slots to))
254 (setf (slot-value to 'initializedp) t)
255 (setf (slots to) (mapcar #'(lambda (x) (prog2
256 (setf (component.place x) (component.place from))
257 x))
258 (slots to))))
259
260 (defmacro call-presentation (object &rest args)
261 `(present-object ,object :presentation (make-presentation ,object ,@args)))