1 (in-package :lisp-on-lines
)
3 (defparameter *default-type
* :ucw
)
5 ;;; some utilities for merging plists
7 (defun plist-nunion (new-props plist
)
8 (loop for cons on new-props by
#'cddr
9 do
(setf (getf plist
(first cons
)) (second cons
))
10 finally
(return plist
)))
12 (defun plist-union (new-props plist
)
13 "Non-destructive version of plist-nunion"
14 (plist-nunion new-props
(copy-list plist
)))
17 ;;; an alist of model-class-name . attributes
18 ;;; should really be a hash-table.
19 (defvar *attribute-map
* (list))
21 (defun find-or-create-attributes (class-name)
22 "return an exisiting class attribute map or create one.
24 A map is a cons of class-name . attributes.
25 attributes is an alist keyed on the attribute name."
26 (or (assoc class-name
*attribute-map
*)
28 (setf *attribute-map
* (acons class-name
(list (list)) *attribute-map
*))
29 (assoc class-name
*attribute-map
*))))
31 (defgeneric find-class-attributes
(class))
33 (defmethod find-class-attributes ((model t
))
34 (find-or-create-attributes (class-name (class-of model
))))
36 (defmethod find-class-attributes ((model symbol
))
37 (find-or-create-attributes model
))
39 (defmethod clear-class-attributes ((model t
))
40 (setf (cdr (find-class-attributes model
)) nil
))
42 (defmethod add-attribute ((model t
) name def
)
43 (let ((map (find-class-attributes model
)))
44 (setf (cdr map
) (acons name def
(cdr map
)))))
46 (defmethod find-attribute ((model t
) name
)
47 (assoc name
(cdr (find-class-attributes model
))))
49 (defmethod (setf find-attribute
) ((def list
) (model t
) name
)
50 (let ((attr (find-attribute model name
)))
56 (add-attribute model name def
)
57 (find-attribute model name
)))))
59 (defmethod set-attribute ((model t
) name definition
&key
(inherit t
))
60 (setf (find-attribute model name
)
62 (cons (car definition
)
63 (plist-union (cdr definition
)
64 (cddr (find-attribute model name
))))
67 (defmethod perform-set-attributes ((model t
) definitions
)
68 (dolist (def definitions
)
69 (funcall #'set-attribute model
(first def
) (rest def
))))
71 (defmethod set-attribute-properties ((model t
) attribute properties
)
72 (let ((a (find-attribute model attribute
)))
74 (setf (cddr a
) (plist-nunion properties
(cddr a
)))
75 (error "Attribute ~A does not exist" attribute
) )))
77 (defmethod perform-set-attribute-properties ((model t
) definitions
)
78 (dolist (def definitions
)
79 (funcall #'set-attribute-properties model
(car def
) (cdr def
))))
81 (defmethod perform-define-attributes ((model t
) attributes
)
82 (loop for attribute in attributes
83 do
(destructuring-bind (name type
&rest args
)
86 ;;use the existing (default) type
87 (set-attribute-properties model name args
))
89 ;;set the type as well
90 (set-attribute model name
(cons type args
)))))))
92 (defmacro define-attributes
(models &body attribute-definitions
)
94 ,@(loop for model in models
95 collect
`(perform-define-attributes (quote ,model
) (quote ,attribute-definitions
)))
96 (mapcar #'find-class-attributes
(quote ,models
))))
98 (defun find-presentation-attributes (model)
99 (remove nil
(mapcar #'(lambda (att)
100 (when (keywordp (car att
))
102 (cdr (find-class-attributes model
)))))
105 ;;;; ** Default Attributes
108 ;;;; The default mewa class contains the types use as defaults.
109 ;;;; maps meta-model slot-types to slot-presentation
111 (defvar *default-attributes-class-name
* 'default
)
113 (define-attributes (default)
114 (boolean mewa-boolean
)
116 (number mewa-currency
)
117 (integer mewa-integer
)
118 (currency mewa-currency
)
119 (clsql:generalized-boolean mewa-boolean
)
120 (foreign-key foreign-key
)
121 (:viewer mewa-viewer
)
122 (:editor mewa-editor
)
123 (:creator mewa-creator
)
124 (:as-string mewa-one-line-presentation
)
125 (:one-line mewa-one-line-presentation
)
126 (:listing mewa-list-presentation
:global-properties
(:editablep nil
) :editablep t
)
127 (:search-model mewa-object-presentation
))
130 (defun find-default-presentation-attributes ()
131 (if (eql *default-attributes-class-name
* 'default
)
132 (find-presentation-attributes 'default
)
133 (remove-duplicates (append
134 (find-presentation-attributes 'default
)
135 (find-presentation-attributes
136 *default-attributes-class-name
*)))))
139 (defmacro with-default-attributes
((model-name) &body body
)
140 `(let ((*default-attributes-class-name
* ',model-name
))
143 (defun gen-ptype (type)
144 (let ((type (if (consp type
) (car type
) type
)))
145 (or (second (find-attribute *default-attributes-class-name
* type
))
146 (second (find-attribute 'default type
))
149 (defun gen-presentation-slots (instance)
150 (mapcar #'(lambda (x) (gen-pslot (cadr x
)
153 (meta-model:list-slot-types instance
)))
156 (defun gen-pslot (type label slot-name
)
157 (copy-list `(,(gen-ptype type
)
159 :slot-name
,slot-name
)))
161 (defun gen-presentation-args (instance args
)
162 (declare (ignore instance
))
166 (defmethod find-default-attributes ((model t
))
167 "return the default attributes for a given model using the meta-model's meta-data"
168 (append (mapcar #'(lambda (s)
171 (if (meta-model:foreign-key-p model
(car s
))
174 (string (car s
)) (car s
))))
175 (meta-model:list-slot-types model
))
176 (mapcar #'(lambda (s)
177 (cons s
(append (gen-pslot 'has-many
(string s
) s
)
182 (meta-model:list-has-many model
))
183 (find-default-presentation-attributes)))
185 (defmethod set-default-attributes ((model t
))
186 "Set the default attributes for MODEL"
187 (clear-class-attributes model
)
188 (mapcar #'(lambda (x)
189 (setf (find-attribute model
(car x
)) (cdr x
)))
190 (find-default-attributes model
)))
193 (defgeneric attributes-getter
(model))
197 (defcomponent mewa
()
198 ((instance :accessor instance
:initarg
:instance
)
204 :accessor attributes-getter
205 :initform
#'get-attributes
206 :initarg
:attributes-getter
)
208 :accessor attribute-slot-map
211 :initarg
:global-properties
212 :accessor global-properties
218 (use-instance-class-p
219 :initarg
:use-instance-class-p
220 :accessor use-instance-class-p
222 (initializedp :initform nil
)
223 (modifiedp :accessor modifiedp
:initform nil
:initarg
:modifiedp
)
224 (modifications :accessor modifications
:initform nil
)))
227 (defmethod attributes :around
((self mewa
))
228 (let ((a (call-next-method)))
229 (or a
(funcall (attributes-getter self
) self
))))
231 (defgeneric get-attributes
(mewa))
233 (defmethod get-attributes ((self mewa
))
235 (append (meta-model:list-slots
(instance self
))
236 (meta-model:list-has-many
(instance self
)))
239 (defmethod find-instance-classes ((self mewa
))
241 (it.bese.arnesi.mopp
:compute-class-precedence-list
(class-of (instance self
)))))
243 (defmethod find-all-attributes ((self mewa
))
245 (mapcar #'(lambda (x)
246 (cdr (find-class-attributes x
)))
249 (defun make-attribute (&rest props
&key type
&allow-other-keys
)
251 (cons (gensym) (cons type props
)))
254 (defmethod find-applicable-attributes ((self mewa
))
255 (let ((all-attributes (find-all-attributes self
)))
256 (flet ((gen-att (x) (let ((att (assoc x all-attributes
)))
258 (setf (cddr att
) (plist-union (global-properties self
) (cddr att
)))
260 (if (attributes self
)
262 (mapcar #'(lambda (x)
267 ;;if the car is a keyword then this is an inline def
268 ((and (listp x
) (keywordp (car x
)))
269 (let ((att (apply #'make-attribute x
)))
271 (plist-union (cddr att
) (global-properties self
)))
273 ;; if the plist has a :type
274 ((and (listp x
) (getf (cdr x
) :type
))
275 (let ((new (cdr (apply #'make-attribute
(cdr x
))))
276 (def (gen-att (car x
))))
277 (setf (cdr new
) (plist-union (cdr new
) (cddr def
)))
278 (cons (car def
) new
)))
279 ;;finally if we are just overiding the props
280 ((and (listp x
) (symbolp (car x
)))
282 (let ((new (cdr (apply #'make-attribute
(cdr x
))))
283 (def (gen-att (car x
))))
285 (setf (cdr new
) (plist-union (cdr new
) (cddr def
)))
286 (cons (car def
) (cons (second def
) (cdr new
)))))))
291 (defmethod find-slot-presentation-for-attribute ((self mewa
) attribute
)
293 (or (gethash (if (consp (second attribute
))
294 (car (second attribute
))
296 *presentation-slot-type-mapping
*)
297 (error "Can't find slot type for ~A in ~A" attribute self
))))
299 (cons (first attribute
) (apply #'make-instance
301 (append (cddr attribute
) (list :parent self
:size
30))))))
303 (defmethod find-slot-presentations ((self mewa
))
304 (mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a
))
305 (find-applicable-attributes self
)))
307 (defmethod find-attribute-slot ((self mewa
) (attribute symbol
))
308 (cdr (assoc attribute
(attribute-slot-map self
))))
310 (defmethod initialize-slots ((self mewa
))
311 (when (instance self
)
312 (when (use-instance-class-p self
)
314 (append (find-instance-classes self
)
316 (setf (attribute-slot-map self
) (find-slot-presentations self
))
317 (setf (slots self
) (mapcar #'(lambda (x)(cdr x
)) (attribute-slot-map self
)))))
320 (defmethod make-presentation ((object t
) &key
(type :viewer
) (initargs nil
))
321 ;(warn "Initargs : ~A" initargs)
322 (let* ((p (make-instance 'mewa-object-presentation
))
324 (a (progn (setf (slot-value p
'instance
) object
)
326 (assoc type
(find-all-attributes p
))))
327 (i (apply #'make-instance
(or (second a
)
328 ;; if we didnt find the type,
329 ;; use the symbol as a class.
330 (if (eql (symbol-package type
)
331 (find-package 'keyword
))
334 (plist-union initargs
(cddr a
)))))
336 (setf (slot-value i
'instance
) object
)
338 (setf (slot-value i
'initializedp
) t
)
341 (defmethod make-presentation ((list list
) &key
(type :listing
) (initargs nil
))
348 (apply #'make-presentation
(car list
) args
)))
350 (defmethod initialize-slots-place ((place ucw
::place
) (mewa mewa
))
351 (setf (slots mewa
) (mapcar #'(lambda (x)
353 (setf (component.place x
) place
)))
356 (arnesi:defmethod
/cc call-component
:before
((from standard-component
) (to mewa
))
357 (unless (slot-value to
'initializedp
)
358 (initialize-slots to
))
359 (setf (slot-value to
'initializedp
) t
)
360 (initialize-slots-place (component.place from
) to
)
365 (defmacro call-presentation
(object &rest args
)
366 `(present-object ,object
:presentation
(make-presentation ,object
,@args
)))
369 (defcomponent about-dialog
(option-dialog)
370 ((body :initarg
:body
)))
372 (defmethod render-on ((res response
) (self about-dialog
))
374 (render-on res
(slot-value self
'body
)))
379 (defaction cancel-save-instance
((self mewa
))
381 ((meta-model::persistentp
(instance self
))
382 (meta-model::update-instance-from-records
(instance self
))
386 (defaction save-instance
((self mewa
))
387 (meta-model:sync-instance
(instance self
))
388 (setf (modifiedp self
) nil
)
391 (defmethod confirm-sync-instance ((self mewa
))
394 (defaction ensure-instance-sync
((self mewa
))
395 (when (modifiedp self
)
397 (let ((message (format nil
"Record has been modified, Do you wish to save the changes?")))
398 (case (call 'about-dialog
399 :body
(make-presentation (instance self
)
402 :options
'((:save .
"Save changes to Database")
403 (:cancel .
"Cancel all changes")))
405 (cancel-save-instance self
))
407 (save-instance self
))))
408 (save-instance self
))))
410 (defaction sync-and-answer
((self mewa
))
411 (ensure-instance-sync self
)
412 (answer (instance self
)))
414 (defaction ok
((self mewa
) &optional arg
)
415 "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
416 ;(declare (ignore arg))
417 (sync-and-answer self
))
419 (defmethod (setf presentation-slot-value
) :around
(value (slot slot-presentation
) instance
)
421 (presentation-slot-value slot instance
)
423 (new (presentation-slot-value slot instance
)))
425 (unless (equal new old
)
426 (let ((self (ucw::parent slot
)))
427 (setf (modifiedp self
) instance
428 (modifications self
) (append (list new old value slot instance
) (modifications self
)))))))
436 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
437 ;; You are granted the rights to distribute
438 ;; and use this software as governed by the terms
439 ;; of the Lisp Lesser GNU Public License
440 ;; (http://opensource.franz.com/preamble.html),
441 ;; known as the LLGPL.