extracted meta-model from LoL into its own archive
[clinton/lisp-on-lines.git] / src / mewa / mewa.lisp
CommitLineData
579597e3 1(in-package :mewa)
2
3(defparameter *default-type* :ucw)
4
5;;; maps meta-model slot-types to slot-presentation
9d6c69fb 6(defparameter *slot-type-map*
38a016c7
DC
7 '(boolean mewa-boolean
8 string mewa-string
9 number mewa-currency
10 integer mewa-integer
11 currency mewa-currency))
579597e3 12
13;;; an alist of model-class-name . attributes
14;;; should really be a hash-table.
15(defvar *attribute-map* (list))
16
17;;; some utilities for merging plists
18
19(defun plist-nunion (new-props plist)
d0c40011 20 (loop for cons on new-props by #'cddr
579597e3 21 do (setf (getf plist (first cons)) (second cons))
22 finally (return plist)))
23
24(defun plist-union (new-props plist)
25 "Non-destructive version of plist-nunion"
26 (plist-nunion new-props (copy-list plist)))
27
28(defun gen-ptype (type)
29 (or (getf *slot-type-map* type) type))
30
31(defun gen-presentation-slots (instance)
32 (mapcar #'(lambda (x) (gen-pslot (cadr x)
33 (string (car x))
34 (car x)))
9d6c69fb 35 (meta-model:list-slot-types instance)))
579597e3 36
37
38(defun gen-pslot (type label slot-name)
39 (copy-list `(,(gen-ptype type)
40 :label ,label
41 :slot-name ,slot-name)))
42
43(defun gen-presentation-args (instance args)
44 (declare (ignore instance))
45 (if args args nil))
46
47
48(defun find-or-create-attributes (class-name)
49 "return an exisiting class attribute map or create one.
50
51A map is a cons of class-name . attributes.
8e6e6b56 52attributes is an alist keyed on the attribute name."
579597e3 53 (or (assoc class-name *attribute-map*)
54 (progn
55 (setf *attribute-map* (acons class-name (list (list)) *attribute-map*))
56 (assoc class-name *attribute-map*))))
57
58(defgeneric find-class-attributes (class))
59
60(defmethod find-class-attributes ((model t))
61 (find-or-create-attributes (class-name (class-of model))))
62
63(defmethod find-class-attributes ((model symbol))
64 (find-or-create-attributes model))
65
46cea8c8
DC
66(defmethod clear-class-attributes ((model t))
67 (setf (cdr (find-class-attributes model)) nil))
68
579597e3 69(defmethod add-attribute ((model t) name def)
70 (let ((map (find-class-attributes model)))
71 (setf (cdr map) (acons name def (cdr map)))))
72
73(defmethod find-attribute ((model t) name)
74 (assoc name (cdr (find-class-attributes model))))
75
76(defmethod (setf find-attribute) ((def list) (model t) name)
77 (let ((attr (find-attribute model name)))
78 (if attr
79 (prog2
80 (setf (cdr attr) def)
81 attr)
82 (prog2
83 (add-attribute model name def)
84 (find-attribute model name)))))
85
86(defmethod set-attribute ((model t) name definition &key (inherit t))
87 (setf (find-attribute model name)
88 (if inherit
89 (cons (car definition)
90 (plist-union (cdr definition)
91 (cddr (find-attribute model name))))
92 definition)))
93
e8e743d7 94(defmethod perform-set-attributes ((model t) definitions)
95 (dolist (def definitions)
96 (funcall #'set-attribute model (first def) (rest def))))
579597e3 97
34e8e2d6
DC
98(defmethod set-attribute-properties ((model t) attribute properties)
99 (let ((a (find-attribute model attribute)))
100 (if a
101 (setf (cddr a) (plist-nunion properties (cddr a)))
102 (error "Attribute ~A does not exist" attribute) )))
103
104(defmethod perform-set-attribute-properties ((model t) definitions)
105 (dolist (def definitions)
106 (funcall #'set-attribute-properties model (car def) (cdr def))))
107
108
19531fbd 109(defmethod default-attributes ((model t))
a6644385 110 "return the default attributes for a given model using the meta-model's meta-data"
7129498f 111 (append (mapcar #'(lambda (s)
112 (cons (car s)
113 (gen-pslot
1679abef 114 (if (meta-model:foreign-key-p model (car s))
38a016c7 115 'foreign-key
1679abef 116 (cadr s))
117 (string (car s)) (car s))))
118 (meta-model:list-slot-types model))
119 (mapcar #'(lambda (s)
38a016c7 120 (cons s (append (gen-pslot 'has-many (string s) s)
1679abef 121 `(:presentation
122 (make-presentation
123 ,model
124 :type :one-line)))))
19531fbd 125 (meta-model:list-has-many model))))
126
127(defmethod set-default-attributes ((model t))
8e6e6b56 128 "Set the default attributes for MODEL"
46cea8c8 129 (clear-class-attributes model)
19531fbd 130 (mapcar #'(lambda (x)
131 (setf (find-attribute model (car x)) (cdr x)))
132 (default-attributes model)))
133
134
579597e3 135(defgeneric attributes-getter (model))
136
19531fbd 137;;;presentations
138
139
140
579597e3 141(defcomponent mewa ()
38a016c7 142 ((instance :accessor instance :initarg :instance)
2cb4247d 143 (attributes
579597e3 144 :initarg :attributes
145 :accessor attributes
146 :initform nil)
147 (attributes-getter
148 :accessor attributes-getter
149 :initform #'get-attributes
150 :initarg :attributes-getter)
569ad9e6
DC
151 (attribute-slot-map
152 :accessor attribute-slot-map
153 :initform nil)
579597e3 154 (global-properties
155 :initarg :global-properties
156 :accessor global-properties
157 :initform nil)
158 (classes
159 :initarg :classes
160 :accessor classes
161 :initform nil)
162 (use-instance-class-p
163 :initarg :use-instance-class-p
164 :accessor use-instance-class-p
165 :initform t)
166 (initializedp :initform nil)
8e6e6b56 167 (modifiedp :accessor modifiedp :initform nil :initarg :modifiedp)
d1bb68e0 168 (modifications :accessor modifications :initform nil)))
579597e3 169
579597e3 170
171(defmethod attributes :around ((self mewa))
172 (let ((a (call-next-method)))
173 (or a (funcall (attributes-getter self) self))))
174
19531fbd 175(defgeneric get-attributes (mewa))
176
579597e3 177(defmethod get-attributes ((self mewa))
178 (if (instance self)
179 (append (meta-model:list-slots (instance self))
180 (meta-model:list-has-many (instance self)))
181 nil))
182
579597e3 183(defmethod find-instance-classes ((self mewa))
184 (mapcar #'class-name
185 (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
186
187(defmethod find-all-attributes ((self mewa))
188 (reduce #'append
189 (mapcar #'(lambda (x)
190 (cdr (find-class-attributes x)))
191 (classes self))))
192
193(defun make-attribute (&rest props &key type &allow-other-keys)
194 (remf props :type)
195 (cons (gensym) (cons type props)))
196
197
198(defmethod find-applicable-attributes ((self mewa))
199 (let ((all-attributes (find-all-attributes self)))
200 (flet ((gen-att (x) (let ((att (assoc x all-attributes)))
201 (when att
202 (setf (cddr att) (plist-union (global-properties self) (cddr att)))
203 att))))
204 (if (attributes self)
205 (remove 'nil
206 (mapcar #'(lambda (x)
207 (cond
208 ;;simple casee
209 ((symbolp x)
210 (gen-att x))
211 ;;if the car is a keyword then this is an inline def
212 ((and (listp x) (keywordp (car x)))
213 (let ((att (apply #'make-attribute x)))
214 (setf (cddr att)
215 (plist-union (cddr att) (global-properties self)))
216 att))
217 ;; if the plist has a :type
218 ((and (listp x) (getf (cdr x) :type))
219 (let ((new (cdr (apply #'make-attribute (cdr x))))
220 (def (gen-att (car x))))
221 (setf (cdr new) (plist-union (cdr new) (cddr def)))
222 (cons (car def) new)))
223 ;;finally if we are just overiding the props
224 ((and (listp x) (symbolp (car x)))
225 (let ((new (cdr (apply #'make-attribute (cdr x))))
226 (def (gen-att (car x))))
227 (setf (cdr new) (plist-union (cdr new) (cddr def)))
228 (cons (car def) (cons (second def) (cdr new)))))
229
230 )
231 )
232
233 (attributes self)))
234 all-attributes))))
235
569ad9e6
DC
236(defmethod find-slot-presentation-for-attribute ((self mewa) attribute)
237 (let ((class-name
5a4eea11
DC
238 (or (gethash (if (consp (second attribute))
239 (car (second attribute))
38a016c7
DC
240 (second attribute))
241 *presentation-slot-type-mapping*)
242 (error "Can't find slot type for ~A in ~A but ~A" attribute *presentation-slot-type-mapping* (gethash 'mewa:has-very-many *presentation-slot-type-mapping*)))))
569ad9e6 243
38a016c7
DC
244 (cons (first attribute) (apply #'make-instance
245 class-name
246 (append (cddr attribute) (list :parent self :size 30))))))
569ad9e6 247
579597e3 248(defmethod find-slot-presentations ((self mewa))
569ad9e6 249 (mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a))
579597e3 250 (find-applicable-attributes self)))
251
569ad9e6
DC
252(defmethod find-attribute-slot ((self mewa) (attribute symbol))
253 (cdr (assoc attribute (attribute-slot-map self))))
579597e3 254
255(defmethod initialize-slots ((self mewa))
65792e79
DC
256 (when (instance self)
257 (when (use-instance-class-p self)
258 (setf (classes self)
259 (append (find-instance-classes self)
260 (classes self))))
261 (setf (attribute-slot-map self) (find-slot-presentations self))
262 (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self )))))
579597e3 263
19531fbd 264(defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
265 (let* ((p (make-instance 'mewa-object-presentation))
68a53dce 266 (a (progn (setf (slot-value p 'ucw::instance) object)
19531fbd 267 (initialize-slots p)
268 (assoc type (find-all-attributes p))))
5a4eea11 269 (i (apply #'make-instance (or (second a)
68a53dce
DC
270 ;; if we didnt find the type,
271 ;; use the symbol as a class.
272 (if (eql (symbol-package type)
273 (find-package 'keyword))
274 (symbol-name type)
275 type))
276 (plist-union initargs (cddr a)))))
19531fbd 277 (setf (slot-value i 'instance) object)
2acd3ba2 278 (initialize-slots i)
279 (setf (slot-value i 'initializedp) t)
19531fbd 280 i))
281
282
8e6e6b56
DC
283(defmethod initialize-slots-place ((place ucw::place) (mewa mewa))
284 (setf (slots mewa) (mapcar #'(lambda (x)
285 (prog1 x
286 (setf (component.place x) place)))
287 (slots mewa))))
288
68a53dce 289(arnesi:defmethod/cc call-component :before ((from standard-component) (to mewa))
579597e3 290 (unless (slot-value to 'initializedp)
291 (initialize-slots to))
292 (setf (slot-value to 'initializedp) t)
68a53dce
DC
293 (initialize-slots-place (component.place from) to)
294 to)
295
296
579597e3 297
298(defmacro call-presentation (object &rest args)
ae09804a 299 `(present-object ,object :presentation (make-presentation ,object ,@args)))
300
4e2ecf69
DC
301
302(defcomponent about-dialog (option-dialog)
303 ((body :initarg :body)))
304
305(defmethod render-on ((res response) (self about-dialog))
d75822e6
DC
306 (call-next-method)
307 (render-on res (slot-value self 'body)))
4e2ecf69 308
8e6e6b56
DC
309
310(defmethod instance-is-stored-p ((instance clsql:standard-db-object))
569ad9e6
DC
311 (slot-value instance 'clsql-sys::view-database))
312
313(defmethod instance-is-stored-p ((mewa mewa))
314 (instance-is-stored-p (instance mewa)))
8e6e6b56 315
ae09804a 316(defaction cancel-save-instance ((self mewa))
1679abef 317 (cond
8e6e6b56 318 ((instance-is-stored-p (instance self))
1679abef 319 (meta-model::update-instance-from-records (instance self))
320 (answer self))
321 (t (answer nil))))
ae09804a 322
323(defaction save-instance ((self mewa))
7129498f 324 (meta-model:sync-instance (instance self))
8e6e6b56
DC
325 (setf (modifiedp self) nil)
326 (answer self))
ae09804a 327
328
12dcf3d4 329(defaction ensure-instance-sync ((self mewa))
ae09804a 330 (when (modifiedp self)
8e6e6b56 331 (let ((message (format nil "Record has been modified, Do you wish to save the changes?")))
4e2ecf69
DC
332 (case (call 'about-dialog
333 :body (make-presentation (instance self)
334 :type :viewer)
ae09804a 335 :message message
336 :options '((:save . "Save changes to Database")
337 (:cancel . "Cancel all changes")))
338 (:cancel
339 (cancel-save-instance self))
340 (:save
12dcf3d4 341 (save-instance self))))))
ae09804a 342
e8e743d7 343(defaction ok ((self mewa) &optional arg)
344 "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
68a53dce
DC
345 ;(declare (ignore arg))
346 (meta-model::sync-instance (instance self))
347 (answer (instance self)))
e8e743d7 348
ae09804a 349(defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
350 (let* ((old (prog1
351 (presentation-slot-value slot instance)
352 (call-next-method)))
353 (new (presentation-slot-value slot instance)))
354
355 (unless (equal new old )
356 (let ((self (ucw::parent slot)))
357 (setf (modifiedp self) instance
4e2ecf69 358 (modifications self) (append (list new old value slot instance) (modifications self)))))))
233380f7 359
ab7ef8e9
DC
360;;;; * Finally set up some defaults
361
362(setf (find-attribute t :viewer)
363 '(mewa-object-presentation :global-properties (:editablep nil))
364 (find-attribute t :editor)
365 '(mewa-object-presentation :global-properties (:editablep t))
65792e79
DC
366 (find-attribute t :creator)
367 '(mewa-object-presentation :global-properties (:editablep t))
ab7ef8e9 368 (find-attribute t :one-line)
65792e79 369 '(mewa-one-line-presentation)
ab7ef8e9 370 (find-attribute t :listing)
65792e79
DC
371 '(mewa-list-presentation :global-properties (:editablep nil) :editablep t)
372 (find-attribute t :search-model)
ab7ef8e9
DC
373 '(mewa-object-presentation))
374
375
376
377
233380f7 378
379;; This software is Copyright (c) Drew Crampsie, 2004-2005.
380;; You are granted the rights to distribute
381;; and use this software as governed by the terms
382;; of the Lisp Lesser GNU Public License
383;; (http://opensource.franz.com/preamble.html),
384;; known as the LLGPL.