re-organized a little, and added support for calling make-presentation with a class...

darcs-hash:20050608024922-39164-80eddff7bb5836f30fe8cfcd894f050ce32e8c9b.gz

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index 031faa3..89ac0d1 100644 (file)
--- a/lisp-on-lines.asd
+++ b/lisp-on-lines.asd
@@ -26,10 +26,11 @@
 
 (defsystem :mewa
   :components ((:module :src 
 
 (defsystem :mewa
   :components ((:module :src 

-               :pathname "src/"
+               :pathname "src/mewa/"

                :components 
                  ((:file "mewa")
                :components 
                  ((:file "mewa")

-                  (:file "ucw" :depends-on ("mewa")))))
+                  (:file "presentations" :depends-on ("mewa"))
+                  (:file "slot-presentations" :depends-on ("presentations")))))

   :depends-on (:ucw :meta-model))
          
 (defsystem :lisp-on-lines
   :depends-on (:ucw :meta-model))
          
 (defsystem :lisp-on-lines

diff --git a/src/mewa.lisp b/src/mewa/mewa.lisp
similarity index 91%
rename from src/mewa.lisp
rename to src/mewa/mewa.lisp
index a0300f6..8509f2d 100644 (file)
--- a/src/mewa.lisp
+++ b/src/mewa/mewa.lisp
@@ -1,5 +1,3 @@
-
-

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


@@ -88,8 +86,28 @@ attributes is an alist keyed on the attribute nreeame."
            definition)))
 
 
            definition)))
 
 

+(defmethod default-attributes ((model t))
+  (append (mapcar #'(lambda (s) (cons (car s) (gen-pslot (if (meta-model:foreign-key-p model (car s))
+                                                  'ucw::foreign-key
+                                                  (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) `(:presentation (make-presentation ,model :type :one-line)))))
+                 (meta-model:list-has-many model))))
+
+(defmethod set-default-attributes ((model t))
+  (mapcar #'(lambda (x) 
+             (setf (find-attribute model (car x)) (cdr x)))
+         (default-attributes model)))
+
+

 (defgeneric attributes-getter (model))
          
 (defgeneric attributes-getter (model))
          

+;;;presentations 
+
+
+
+

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


@@ -114,26 +132,19 @@ attributes is an alist keyed on the attribute nreeame."
    (initializedp :initform nil)
    (modifiedp :accessor modifiedp :initform nil)))
 
    (initializedp :initform nil)
    (modifiedp :accessor modifiedp :initform nil)))
 

-(defcomponent mewa-object-presentation (mewa object-presentation) ())
-
-(defcomponent mewa-one-line-presentation (mewa one-line-presentation)
-  ()
-  (:default-initargs :attributes-getter #'one-line-attributes-getter))

 
 (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))))
 

+(defgeneric get-attributes (mewa))
+

 (defmethod get-attributes ((self mewa))
   (if (instance self)
   (append (meta-model:list-slots (instance self))
          (meta-model:list-has-many (instance self)))
   nil))
 
 (defmethod get-attributes ((self mewa))
   (if (instance self)
   (append (meta-model:list-slots (instance self))
          (meta-model:list-has-many (instance self)))
   nil))
 

-(defmethod one-line-attributes-getter ((self mewa))
-  (or (meta-model:list-keys (instance self))))
-
-

 
 (defmethod find-instance-classes ((self mewa))
   (mapcar #'class-name 
 
 (defmethod find-instance-classes ((self mewa))
   (mapcar #'class-name 


@@ -196,31 +207,6 @@ attributes is an alist keyed on the attribute nreeame."
                     (append (cddr s) (list :parent self)))))
          (find-applicable-attributes self)))
 
                     (append (cddr s) (list :parent self)))))
          (find-applicable-attributes self)))
 

-(defmethod default-attributes ((model t))
-  (append (mapcar #'(lambda (s) (cons (car s) (gen-pslot (if (meta-model:foreign-key-p model (car s))
-                                                  'ucw::foreign-key
-                                                  (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) `(:presentation (make-presentation ,model :type :one-line)))))
-                 (meta-model:list-has-many model))))
-
-(defmethod set-default-attributes ((model t))
-  (mapcar #'(lambda (x) 
-             (setf (find-attribute model (car x)) (cdr x)))
-         (default-attributes model)))
-
-
-(defcomponent mewa-object-presentation (mewa ucw:object-presentation) ())
-
-(defcomponent mewa-list-presentation (mewa ucw:list-presentation) 
-  ((it.bese.ucw::instances :accessor instances :initarg :instances :initform nil)
-      (instance :accessor instance))) ;to make make-presentation happy
-
-(defmethod get-all-instances ((self mewa-list-presentation))
-  (instances self))
-
-

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


@@ -248,6 +234,27 @@ attributes is an alist keyed on the attribute nreeame."
     (setf (slot-value i 'instance) object)
     i))
 
     (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))))
+        
+        (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)))))
+    (setf (slot-value i 'instance) object)
+    i))
+
+
+
+
+

 (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))

diff --git a/src/ucw.lisp b/src/mewa/slot-presentations.lisp
similarity index 96%
rename from src/ucw.lisp
rename to src/mewa/slot-presentations.lisp
index ddf83af..4d89895 100644 (file)
--- a/src/ucw.lisp
+++ b/src/mewa/slot-presentations.lisp
@@ -13,6 +13,9 @@
 (defmethod (setf presentation-slot-value) ((value string) (slot clsql-wall-time-slot-presentation) instance)
   (setf (presentation-slot-value slot instance) (clsql:parse-date-time (remove #\Space value))))
 
 (defmethod (setf presentation-slot-value) ((value string) (slot clsql-wall-time-slot-presentation) instance)
   (setf (presentation-slot-value slot instance) (clsql:parse-date-time (remove #\Space value))))
 

+(defmethod label :around ((slot clsql-wall-time-slot-presentation))
+  (concatenate 'string (call-next-method) "  (mm/dd/yyyy)"))
+

 (defmethod present-slot ((slot clsql-wall-time-slot-presentation) instance)
   (let ((date (presentation-slot-value slot instance))
        (input-id (string (gensym))))
 (defmethod present-slot ((slot clsql-wall-time-slot-presentation) instance)
   (let ((date (presentation-slot-value slot instance))
        (input-id (string (gensym))))


@@ -35,14 +38,13 @@
 
 (defmethod present-relation ((slot mewa-relation-slot-presentation) instance)
  ;;;;(<:as-html (slot-name slot) "=> " (foreign-instance slot) " from " instance )
 
 (defmethod present-relation ((slot mewa-relation-slot-presentation) instance)
  ;;;;(<:as-html (slot-name slot) "=> " (foreign-instance slot) " from " instance )

-  (let* ((e (getf (mewa::global-properties (parent slot)) :editablep))
-        (i (foreign-instance slot))
+  (let* ((i (foreign-instance slot))

         (pres (mewa::make-presentation 
                i
                :type :one-line 
                :initargs (list 
                           :global-properties 
         (pres (mewa::make-presentation 
                i
                :type :one-line 
                :initargs (list 
                           :global-properties 

-                          (list :editablep nil :linkedp (linkedp slot))))))
+                          (list :editablep nil :linkedp nil)))))

       (when (ucw::parent slot) (setf (component.place pres) (component.place (ucw::parent slot))))
       (flet ((render () (when i (<ucw:render-component :component pres))))
       (cond 
       (when (ucw::parent slot) (setf (component.place pres) (component.place (ucw::parent slot))))
       (flet ((render () (when i (<ucw:render-component :component pres))))
       (cond