added define-attributes macro

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

diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp
index b09d594..e620130 100644 (file)
--- a/src/mewa/mewa.lisp
+++ b/src/mewa/mewa.lisp
@@ -4,12 +4,12 @@
 
 ;;; maps meta-model slot-types to slot-presentation
 (defparameter *slot-type-map*
 
 ;;; 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
-    ))
+  '(boolean   mewa-boolean
+    string    mewa-string
+    number    mewa-currency
+    integer   mewa-integer
+    currency  mewa-currency
+    clsql:generalized-boolean mewa-boolean))

 
 ;;; an alist of model-class-name . attributes
 ;;; should really be a hash-table.
 
 ;;; an alist of model-class-name . attributes
 ;;; should really be a hash-table.


@@ -90,7 +90,7 @@ attributes is an alist keyed on the attribute name."
            (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)
 
 (defmethod perform-set-attributes ((model t) definitions)
   (dolist (def definitions)


@@ -105,6 +105,23 @@ attributes is an alist keyed on the attribute name."
 (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 ))))

   
 
 (defmethod default-attributes ((model t))
   
 
 (defmethod default-attributes ((model t))


@@ -113,12 +130,12 @@ attributes is an alist keyed on the attribute name."
                      (cons (car s) 
                            (gen-pslot 
                             (if (meta-model:foreign-key-p model (car 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 
                                      `(:presentation 
                                        (make-presentation 
                                         ,model 


@@ -137,10 +154,8 @@ attributes is an alist keyed on the attribute name."
          
 ;;;presentations 
 
          
 ;;;presentations 
 

-
-

 (defcomponent mewa ()
 (defcomponent mewa ()

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

    (attributes
     :initarg :attributes
     :accessor attributes
    (attributes
     :initarg :attributes
     :accessor attributes


@@ -238,13 +253,13 @@ attributes is an alist keyed on the attribute name."
   (let ((class-name 
         (or (gethash (if (consp (second attribute))
                          (car (second attribute))
   (let ((class-name 
         (or (gethash (if (consp (second attribute))
                          (car (second attribute))

-                              (second attribute))
-                              ucw::*slot-type-mapping*) 
-            (error  "Can't find slot type for ~A" (second attribute)))))
+                         (second attribute))
+                     *presentation-slot-type-mapping*) 
+            (error  "Can't find slot type for ~A in ~A" attribute *presentation-slot-type-mapping* ))))

                
                

-         (cons (first attribute) (apply #'make-instance 
-          class-name
-          (append (cddr attribute) (list :parent self :size 30))))))
+    (cons (first attribute) (apply #'make-instance 
+                                  class-name
+                                  (append (cddr attribute) (list :parent self :size 30))))))

 
 (defmethod find-slot-presentations ((self mewa))
   (mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a))
 
 (defmethod find-slot-presentations ((self mewa))
   (mapcar #'(lambda (a) (find-slot-presentation-for-attribute self a))


@@ -267,7 +282,6 @@ attributes is an alist keyed on the attribute name."
         (a (progn (setf (slot-value p 'ucw::instance) object)
                   (initialize-slots p) 
                   (assoc type (find-all-attributes p))))
         (a (progn (setf (slot-value p 'ucw::instance) object)
                   (initialize-slots p) 
                   (assoc type (find-all-attributes p))))

-        ;;;; TODO: this can be cleaned up, probably CHANGE-CLASS is better here

         (i (apply #'make-instance (or (second a)
                                      ;; if we didnt find the type, 
                                      ;; use the symbol as a class. 
         (i (apply #'make-instance (or (second a)
                                      ;; if we didnt find the type, 
                                      ;; use the symbol as a class.