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 af4ecbb..e620130 100644 (file)
--- a/src/mewa/mewa.lisp
+++ b/src/mewa/mewa.lisp
@@ -8,7 +8,8 @@
     string    mewa-string
     number    mewa-currency
     integer   mewa-integer
-    currency  mewa-currency))
+    currency  mewa-currency
+    clsql:generalized-boolean mewa-boolean))
 
 ;;; an alist of model-class-name . attributes
 ;;; should really be a hash-table.
@@ -89,7 +90,7 @@ attributes is an alist keyed on the attribute 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)
@@ -104,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-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))
@@ -136,8 +154,6 @@ attributes is an alist keyed on the attribute name."
          
 ;;;presentations 
 
-
-
 (defcomponent mewa ()
   ((instance :accessor instance :initarg :instance) 
    (attributes
@@ -239,7 +255,7 @@ attributes is an alist keyed on the attribute name."
                          (car (second attribute))
                          (second attribute))
                      *presentation-slot-type-mapping*) 
-            (error  "Can't find slot type for ~A in ~A but ~A" attribute *presentation-slot-type-mapping* (gethash 'mewa:has-very-many *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