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

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

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)
@@ -88,8 +86,28 @@ attributes is an alist keyed on the attribute nreeame."
            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))
          
+;;;presentations 
+
+
+
+
 (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)))
 
-(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))))
 
+(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 one-line-attributes-getter ((self mewa))
-  (or (meta-model:list-keys (instance self))))
-
-
 
 (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)))
 
-(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))
@@ -248,6 +234,27 @@ attributes is an alist keyed on the attribute nreeame."
     (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))