Cleanud up some defaults and made slots accessable by name.

[clinton/lisp-on-lines.git] / src / mewa / mewa.lisp

diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp
index 80795c8..7cdb073 100644 (file)
--- a/src/mewa/mewa.lisp
+++ b/src/mewa/mewa.lisp
@@ -51,7 +51,7 @@
   "return an exisiting class attribute map or create one. 
 
 A map is a cons of class-name . attributes. 
   "return an exisiting class attribute map or create one. 
 
 A map is a cons of class-name . attributes. 

-attributes is an alist keyed on the attribute nreeame."
+attributes is an alist keyed on the attribute name."

   (or (assoc class-name *attribute-map*) 
       (progn 
        (setf *attribute-map* (acons class-name (list (list)) *attribute-map*)) 
   (or (assoc class-name *attribute-map*) 
       (progn 
        (setf *attribute-map* (acons class-name (list (list)) *attribute-map*)) 


@@ -97,7 +97,6 @@ attributes is an alist keyed on the attribute nreeame."
   (dolist (def definitions)
     (funcall #'set-attribute model (first def) (rest def))))
 
   (dolist (def definitions)
     (funcall #'set-attribute model (first def) (rest def))))
 

-

 (defmethod set-attribute-properties ((model t) attribute properties)
   (let ((a (find-attribute model attribute)))
     (if a
 (defmethod set-attribute-properties ((model t) attribute properties)
   (let ((a (find-attribute model attribute)))
     (if a


@@ -109,9 +108,6 @@ attributes is an alist keyed on the attribute nreeame."
     (funcall #'set-attribute-properties model (car def) (cdr def))))
   
 
     (funcall #'set-attribute-properties model (car def) (cdr def))))
   
 

-
-
-

 (defmethod default-attributes ((model t))
   "return the default attributes for a given model using the meta-model's meta-data"
   (append (mapcar #'(lambda (s) 
 (defmethod default-attributes ((model t))
   "return the default attributes for a given model using the meta-model's meta-data"
   (append (mapcar #'(lambda (s) 


@@ -131,6 +127,7 @@ attributes is an alist keyed on the attribute nreeame."
                  (meta-model:list-has-many model))))
 
 (defmethod set-default-attributes ((model t))
                  (meta-model:list-has-many model))))
 
 (defmethod set-default-attributes ((model t))

+  "Set the default attributes for MODEL"

   (clear-class-attributes model)
   (mapcar #'(lambda (x) 
              (setf (find-attribute model (car x)) (cdr x)))
   (clear-class-attributes model)
   (mapcar #'(lambda (x) 
              (setf (find-attribute model (car x)) (cdr x)))


@@ -143,7 +140,6 @@ attributes is an alist keyed on the attribute nreeame."
 
 
 
 
 
 

-

 (defcomponent mewa ()
   ((attributes
     :initarg :attributes
 (defcomponent mewa ()
   ((attributes
     :initarg :attributes


@@ -153,6 +149,9 @@ attributes is an alist keyed on the attribute nreeame."
     :accessor attributes-getter
     :initform #'get-attributes
     :initarg :attributes-getter)
     :accessor attributes-getter
     :initform #'get-attributes
     :initarg :attributes-getter)

+   (attribute-slot-map
+    :accessor attribute-slot-map
+    :initform nil)

    (global-properties
     :initarg :global-properties
     :accessor global-properties
    (global-properties
     :initarg :global-properties
     :accessor global-properties


@@ -166,10 +165,14 @@ attributes is an alist keyed on the attribute nreeame."
     :accessor use-instance-class-p 
     :initform t)
    (initializedp :initform nil)
     :accessor use-instance-class-p 
     :initform t)
    (initializedp :initform nil)

-   (modifiedp :accessor modifiedp :initform nil)
+   (modifiedp :accessor modifiedp :initform nil :initarg :modifiedp)

    (modifications :accessor modifications :initform nil)))
 
 
    (modifications :accessor modifications :initform nil)))
 
 

+
+
+
+

 (defmethod attributes :around ((self mewa))
   (let ((a (call-next-method)))
     (or a (funcall (attributes-getter self) self))))
 (defmethod attributes :around ((self mewa))
   (let ((a (call-next-method)))
     (or a (funcall (attributes-getter self) self))))


@@ -182,7 +185,6 @@ attributes is an alist keyed on the attribute nreeame."
          (meta-model:list-has-many (instance self)))
   nil))
 
          (meta-model:list-has-many (instance self)))
   nil))
 

-

 (defmethod find-instance-classes ((self mewa))
   (mapcar #'class-name 
          (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
 (defmethod find-instance-classes ((self mewa))
   (mapcar #'class-name 
          (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))


@@ -236,22 +238,30 @@ attributes is an alist keyed on the attribute nreeame."
                        (attributes self)))
       all-attributes))))
 
                        (attributes self)))
       all-attributes))))
 

+(defmethod find-slot-presentation-for-attribute ((self mewa) attribute)
+  (let ((class-name 
+        (or (gethash (second attribute) ucw::*slot-type-mapping*) 
+            (error  "Can't find slot type for ~A" (second attribute)))))
+               
+         (cons (first attribute) (apply #'make-instance 
+          class-name
+          (append (cddr attribute) (list :parent self :size 30))))))
+

 (defmethod find-slot-presentations ((self mewa))
 (defmethod find-slot-presentations ((self mewa))

-  (mapcar #'(lambda (s)
-             (let ((class-name (or (gethash (second s) ucw::*slot-type-mapping*) 'mewa-object-presentation)))
-             (apply #'make-instance 
-                    class-name
-                    (append (cddr s) (list :parent self)))))
+  (mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a))

          (find-applicable-attributes self)))
 
          (find-applicable-attributes self)))
 

-
+(defmethod find-attribute-slot ((self mewa) (attribute symbol))
+  (cdr (assoc attribute (attribute-slot-map self))))

 
 (defmethod initialize-slots ((self mewa))
 
 (defmethod initialize-slots ((self mewa))

-  (when (use-instance-class-p self)
-    (setf (classes self) 
-         (append (find-instance-classes self)
-                 (classes self))))
-  (setf (slots self) (find-slot-presentations   self)))
+  (when (instance self)
+    (when (use-instance-class-p self)
+      (setf (classes self) 
+           (append (find-instance-classes self)
+                   (classes self))))
+    (setf (attribute-slot-map self) (find-slot-presentations self))
+    (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self )))))

   
 
 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
   
 
 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))


@@ -284,9 +294,12 @@ attributes is an alist keyed on the attribute nreeame."
     i))
 
 
     i))
 
 

-
-
-
+(defmethod initialize-slots-place ((place ucw::place) (mewa mewa))
+  (setf (slots mewa) (mapcar #'(lambda (x) 
+                              (prog1 x 
+                                (setf (component.place x) place)))
+                            (slots mewa))))
+  

 (defmethod call-component :before ((from standard-component) (to mewa))
   (unless (slot-value to 'initializedp)
     (initialize-slots to))
 (defmethod call-component :before ((from standard-component) (to mewa))
   (unless (slot-value to 'initializedp)
     (initialize-slots to))


@@ -304,25 +317,32 @@ attributes is an alist keyed on the attribute nreeame."
   ((body :initarg :body)))
 
 (defmethod render-on ((res response) (self about-dialog))
   ((body :initarg :body)))
 
 (defmethod render-on ((res response) (self about-dialog))

-  (render-on res (slot-value self 'body))
-  (call-next-method))
+  (call-next-method)
+  (render-on res (slot-value self 'body)))
+
+
+(defmethod instance-is-stored-p ((instance clsql:standard-db-object))
+  (slot-value instance 'clsql-sys::view-database))
+
+(defmethod instance-is-stored-p ((mewa mewa))
+  (instance-is-stored-p (instance mewa)))

 
 (defaction cancel-save-instance ((self mewa))
   (cond  
 
 (defaction cancel-save-instance ((self mewa))
   (cond  

-    ((slot-value (instance self) 'clsql-sys::view-database)
+    ((instance-is-stored-p (instance self))

       (meta-model::update-instance-from-records (instance self))
       (answer self))
     (t (answer nil))))
 
 (defaction save-instance ((self mewa))
   (meta-model:sync-instance (instance self))
       (meta-model::update-instance-from-records (instance self))
       (answer self))
     (t (answer nil))))
 
 (defaction save-instance ((self mewa))
   (meta-model:sync-instance (instance self))

-   (setf (modifiedp self) nil)
-       (answer self))
+  (setf (modifiedp self) nil)
+  (answer self))

 
 
 (defaction ensure-instance-sync ((self mewa))
   (when (modifiedp self)
 
 
 (defaction ensure-instance-sync ((self mewa))
   (when (modifiedp self)

-    (let ((message (format nil "Record has been modified, Do you wish to save the changes?<br/> ~a" (print (modifications self)))))
+    (let ((message (format nil "Record has been modified, Do you wish to save the changes?")))

       (case (call 'about-dialog
                   :body (make-presentation (instance self) 
                                           :type :viewer)
       (case (call 'about-dialog
                   :body (make-presentation (instance self) 
                                           :type :viewer)


@@ -340,10 +360,6 @@ attributes is an alist keyed on the attribute nreeame."
   (ensure-instance-sync self)
   (answer self))
 
   (ensure-instance-sync self)
   (answer self))
 

-
-
-
-

 (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
   (let* ((old (prog1 
                 (presentation-slot-value slot instance)
 (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
   (let* ((old (prog1 
                 (presentation-slot-value slot instance)


@@ -355,6 +371,24 @@ attributes is an alist keyed on the attribute nreeame."
       (setf (modifiedp self) instance
            (modifications self)  (append (list new old value slot instance) (modifications self)))))))
 
       (setf (modifiedp self) instance
            (modifications self)  (append (list new old value slot instance) (modifications self)))))))
 

+;;;; * Finally set up some defaults
+
+(setf (find-attribute t :viewer) 
+      '(mewa-object-presentation :global-properties (:editablep nil))
+      (find-attribute t :editor)
+      '(mewa-object-presentation :global-properties (:editablep t))
+      (find-attribute t :creator)
+      '(mewa-object-presentation :global-properties (:editablep t))
+      (find-attribute t :one-line)
+      '(mewa-one-line-presentation)
+      (find-attribute t :listing)
+      '(mewa-list-presentation :global-properties (:editablep nil) :editablep t)
+      (find-attribute t :search-model)
+      '(mewa-object-presentation))
+
+
+
+

 
 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
 ;; You are granted the rights to distribute
 
 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
 ;; You are granted the rights to distribute