Added a make-presentation for a LIST argument.

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

diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp
index fea4984..cf6ea00 100644 (file)
--- a/src/mewa/mewa.lisp
+++ b/src/mewa/mewa.lisp
@@ -1,21 +1,7 @@
-

 (in-package :mewa)
  
 (defparameter *default-type* :ucw)
 
 (in-package :mewa)
  
 (defparameter *default-type* :ucw)
 

-;;; maps meta-model slot-types to slot-presentation
-(defparameter *slot-type-map*
-  '(boolean   ucw::mewa-boolean
-    string    ucw::mewa-string
-    number    ucw::mewa-currency
-    integer   ucw::mewa-integer
-    currency  ucw::mewa-currency
-    ))
-
-;;; an alist of model-class-name . attributes
-;;; should really be a hash-table.
-(defvar *attribute-map* (list)) 
-

 ;;; some utilities for merging plists
 
 (defun plist-nunion (new-props plist)
 ;;; some utilities for merging plists
 
 (defun plist-nunion (new-props plist)


@@ -27,31 +13,16 @@
   "Non-destructive version of plist-nunion"
                   (plist-nunion new-props (copy-list plist)))
 
   "Non-destructive version of plist-nunion"
                   (plist-nunion new-props (copy-list plist)))
 

-(defun gen-ptype (type)
-  (or (getf *slot-type-map* type) type))
-
-(defun gen-presentation-slots (instance)
-  (mapcar #'(lambda (x) (gen-pslot (cadr x) 
-                                  (string (car x)) 
-                                  (car x))) 
-         (meta-model:list-slot-types instance)))
-
-
-(defun gen-pslot (type label slot-name)
-  (copy-list `(,(gen-ptype type) 
-              :label ,label
-              :slot-name ,slot-name))) 
-
-(defun gen-presentation-args (instance args)
-  (declare (ignore instance))
-  (if args args nil))

 
 

+;;; an alist of model-class-name . attributes
+;;; should really be a hash-table.
+(defvar *attribute-map* (list))

 
 (defun find-or-create-attributes (class-name)
   "return an exisiting class attribute map or create one. 
 
 A map is a cons of class-name . attributes. 
 
 (defun find-or-create-attributes (class-name)
   "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*)) 


@@ -91,13 +62,12 @@ attributes is an alist keyed on the attribute nreeame."
            (cons (car definition) 
                  (plist-union (cdr definition)
                         (cddr (find-attribute model name))))
            (cons (car definition) 
                  (plist-union (cdr definition)
                         (cddr (find-attribute model name))))

-           definition)))
+           definition))) 

 
 (defmethod perform-set-attributes ((model t) definitions)
   (dolist (def definitions)
     (funcall #'set-attribute model (first def) (rest def))))
 
 
 (defmethod perform-set-attributes ((model t) definitions)
   (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


@@ -107,45 +77,125 @@ attributes is an alist keyed on the attribute nreeame."
 (defmethod perform-set-attribute-properties ((model t) definitions)
   (dolist (def definitions)
     (funcall #'set-attribute-properties model (car def) (cdr def))))
 (defmethod perform-set-attribute-properties ((model t) definitions)
   (dolist (def definitions)
     (funcall #'set-attribute-properties model (car def) (cdr def))))

+
+(defmethod perform-define-attributes ((model t) attributes)
+  (loop for attribute in attributes
+       do (destructuring-bind (name type &rest args)
+                 attribute
+               (cond ((eq type t)
+                      ;;use the existing (default) type
+                      (set-attribute-properties model name args))
+                     ((not (null type))
+                      ;;set the type as well
+                      (set-attribute model name (cons type args)))))))
+                      
+(defmacro define-attributes (models &body attribute-definitions)
+  `(progn
+    ,@(loop for model in models
+           collect `(perform-define-attributes (quote ,model) (quote ,attribute-definitions)))
+  (mapcar #'find-class-attributes (quote ,models ))))
+
+(defun find-presentation-attributes (model)
+  (remove nil (mapcar #'(lambda (att)
+             (when (keywordp (car att))
+               att))
+         (cdr (find-class-attributes model)))))
+
+
+;;;; ** Default Attributes
+
+
+;;;; The default mewa class contains the types use as defaults.
+;;;; maps meta-model slot-types to slot-presentation
+
+(defvar *default-attributes-class-name* 'default)
+
+(define-attributes (default)
+  (boolean mewa-boolean)
+  (string mewa-string)
+  (number mewa-currency)
+  (integer   mewa-integer)
+  (currency  mewa-currency)
+  (clsql:generalized-boolean mewa-boolean)
+  (foreign-key foreign-key)
+  (:viewer mewa-viewer)
+  (:editor mewa-editor)
+  (:creator mewa-creator)
+  (:one-line mewa-one-line-presentation)
+  (:listing mewa-list-presentation :global-properties (:editablep nil) :editablep t)
+  (:search-model mewa-object-presentation))
+

   
   

+(defun find-default-presentation-attributes ()
+  (if (eql *default-attributes-class-name* 'default)
+      (find-presentation-attributes 'default)
+      (remove-duplicates (append
+                         (find-presentation-attributes 'default)
+                         (find-presentation-attributes
+                          *default-attributes-class-name*)))))
+
+
+(defmacro with-default-attributes ((model-name) &body body)
+  `(let ((*default-attributes-class-name* ',model-name))
+    ,@body))
+
+(defun gen-ptype (type)
+  (let ((type (if (consp type) (car type) type)))
+  (or (second (find-attribute *default-attributes-class-name* type))
+      (second (find-attribute 'default type))
+      type)))

 
 

+(defun gen-presentation-slots (instance)
+  (mapcar #'(lambda (x) (gen-pslot (cadr x) 
+                                  (string (car x)) 
+                                  (car x))) 
+         (meta-model:list-slot-types instance)))

 
 
 
 

+(defun gen-pslot (type label slot-name)
+  (copy-list `(,(gen-ptype type) 
+              :label ,label
+              :slot-name ,slot-name))) 

 
 

-(defmethod default-attributes ((model t))
+(defun gen-presentation-args (instance args)
+  (declare (ignore instance))
+  (if args args nil))
+
+
+(defmethod find-default-attributes ((model t))

   "return the default attributes for a given model using the meta-model's meta-data"
   (append (mapcar #'(lambda (s) 
                      (cons (car s) 
                            (gen-pslot 
                             (if (meta-model:foreign-key-p model (car s))
   "return the default attributes for a given model using the meta-model's meta-data"
   (append (mapcar #'(lambda (s) 
                      (cons (car s) 
                            (gen-pslot 
                             (if (meta-model:foreign-key-p model (car s))

-                                'ucw::foreign-key
+                                'foreign-key

                                 (cadr s))
                             (string (car s)) (car s)))) 
                  (meta-model:list-slot-types model))
          (mapcar #'(lambda (s) 
                                 (cadr s))
                             (string (car s)) (car s)))) 
                  (meta-model:list-slot-types model))
          (mapcar #'(lambda (s) 

-                     (cons s (append (gen-pslot 'ucw::has-many (string s) s) 
+                     (cons s (append (gen-pslot 'has-many (string s) s) 

                                      `(:presentation 
                                        (make-presentation 
                                         ,model 
                                         :type :one-line)))))
                                      `(:presentation 
                                        (make-presentation 
                                         ,model 
                                         :type :one-line)))))

-                 (meta-model:list-has-many model))))
+                 (meta-model:list-has-many model))
+         (find-default-presentation-attributes)))

 
 (defmethod set-default-attributes ((model t))
 
 (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)))

-         (default-attributes model)))
+         (find-default-attributes model)))

 
 
 (defgeneric attributes-getter (model))
          
 ;;;presentations 
 
 
 
 (defgeneric attributes-getter (model))
          
 ;;;presentations 
 

-
-
-

 (defcomponent mewa ()
 (defcomponent mewa ()

-  ((attributes
+  ((instance :accessor instance :initarg :instance) 
+   (attributes

     :initarg :attributes
     :accessor attributes
     :initform nil)
     :initarg :attributes
     :accessor attributes
     :initform nil)


@@ -153,6 +203,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,7 +219,7 @@ 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)))
 
 


@@ -182,7 +235,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,65 +288,77 @@ 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 (if (consp (second attribute))
+                         (car (second attribute))
+                         (second attribute))
+                     *presentation-slot-type-mapping*) 
+            (error  "Can't find slot type for ~A in ~A" attribute self ))))
+               
+    (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 :size 30)))))
+  (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))
-  (let* ((p (make-instance 'mewa-object-presentation))
-        (a (progn (setf (slot-value p 'instance) object)
-                  (initialize-slots p) 
-                  (assoc type (find-all-attributes p))))
-        
-        (i (apply #'make-instance (second a) (plist-union initargs (cddr a)))))
-    (setf (slot-value i 'instance) object)
-    i))

 
 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
   (let* ((p (make-instance 'mewa-object-presentation))
         (a (progn (setf (slot-value p 'instance) object)
                   (initialize-slots p) 
                   (assoc type (find-all-attributes p))))
 
 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
   (let* ((p (make-instance 'mewa-object-presentation))
         (a (progn (setf (slot-value p 'instance) object)
                   (initialize-slots p) 
                   (assoc type (find-all-attributes p))))

-        

         (i (apply #'make-instance (or (second a)
         (i (apply #'make-instance (or (second a)

-                                      ;; if we didnt find the type, 
-                                      ;; use the symbol as a class. 
-                                      (if (eql (symbol-package type) 
-                                               (find-package 'keyword))
-                                          (symbol-name type)
-                                          type))
-                                      (plist-union initargs (cddr a)))))
+                                     ;; if we didnt find the type, 
+                                     ;; use the symbol as a class. 
+                                     (if (eql (symbol-package type) 
+                                              (find-package 'keyword))
+                                         (symbol-name type)
+                                         type))
+                  (plist-union initargs (cddr a)))))

     (setf (slot-value i 'instance) object)
     (initialize-slots i)
     (setf (slot-value i 'initializedp) t)
     i))
 
     (setf (slot-value i 'instance) object)
     (initialize-slots i)
     (setf (slot-value i 'initializedp) t)
     i))
 

-
-
-
-
-(defmethod call-component :before ((from standard-component) (to mewa))
+(defmethod make-presentation ((list list) &key (type :listing) (initargs nil))
+
+  (let ((args (append
+              `(:type ,type) 
+              `(:initargs 
+                (:instances ,list
+                 ,@initargs)))))
+    
+    (apply #'make-presentation (car list) args)))
+
+(defmethod initialize-slots-place ((place ucw::place) (mewa mewa))
+  (setf (slots mewa) (mapcar #'(lambda (x) 
+                              (prog1 x 
+                                (setf (component.place x) place)))
+                            (slots mewa))))
+  
+(arnesi:defmethod/cc call-component :before ((from standard-component) (to mewa))

   (unless (slot-value to 'initializedp)
     (initialize-slots to))
   (setf (slot-value to 'initializedp) t)
   (unless (slot-value to 'initializedp)
     (initialize-slots to))
   (setf (slot-value to 'initializedp) t)

-  (setf (slots to) (mapcar #'(lambda (x) (prog2 
-                                            (setf (component.place x) (component.place from))
-                                            x))
-                            (slots to))))
+  (initialize-slots-place (component.place from) to)
+  to)
+
+

 
 (defmacro call-presentation (object &rest args)
   `(present-object ,object :presentation (make-presentation ,object ,@args)))
 
 (defmacro call-presentation (object &rest args)
   `(present-object ,object :presentation (make-presentation ,object ,@args)))


@@ -307,38 +371,51 @@ attributes is an alist keyed on the attribute nreeame."
   (call-next-method)
   (render-on res (slot-value self 'body)))
 
   (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))

 
 

+(defmethod confirm-sync-instance ((self mewa))
+  nil)

 
 (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)))))
-      (case (call 'about-dialog
-                  :body (make-presentation (instance self) 
-                                          :type :viewer)
-                 :message message
-                 :options '((:save . "Save changes to Database")
-                            (:cancel . "Cancel all changes")))
-       (:cancel
-        (cancel-save-instance self))
-       (:save 
-        (save-instance self))))))
+    (if nil
+       (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)
+                     :message message
+                     :options '((:save . "Save changes to Database")
+                                (:cancel . "Cancel all changes")))
+           (:cancel
+            (cancel-save-instance self))
+           (:save 
+            (save-instance self))))
+       (save-instance self))))
+
+(defaction sync-and-answer ((self mewa))
+  (ensure-instance-sync self)
+  (answer (instance self)))

 
 (defaction ok ((self mewa) &optional arg)
   "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
 
 (defaction ok ((self mewa) &optional arg)
   "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"

-  (declare (ignore arg))
-  (ensure-instance-sync self)
-  (answer self))
+  ;(declare (ignore arg))
+  (sync-and-answer self))

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


@@ -352,6 +429,11 @@ attributes is an alist keyed on the attribute nreeame."
            (modifications self)  (append (list new old value slot instance) (modifications self)))))))
 
 
            (modifications self)  (append (list new old value slot instance) (modifications self)))))))
 
 

+
+
+
+
+

 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
 ;; You are granted the rights to distribute
 ;; and use this software as governed by the terms
 ;; This software is Copyright (c) Drew Crampsie, 2004-2005.
 ;; You are granted the rights to distribute
 ;; and use this software as governed by the terms