X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/5a4eea119b2c7d1c5a3bbd374e8a26e0b5e1d04f..fc3e754fa505c6f725ebe962917eabc1dc8f8ce2:/src/mewa/mewa.lisp

diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp
index b09d594..e620130 100644
--- 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*
-  '(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.
@@ -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))))
-	    definition)))
+	    definition))) 
 
 (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-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))
@@ -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))
-				 'ucw::foreign-key
+				 '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) 
+		      (cons s (append (gen-pslot 'has-many (string s) s) 
 				      `(:presentation 
 					(make-presentation 
 					 ,model 
@@ -137,10 +154,8 @@ attributes is an alist keyed on the attribute name."
 	  
 ;;;presentations 
 
-
-
 (defcomponent mewa ()
-  ((ucw::instance :accessor instance :initarg :instance) 
+  ((instance :accessor instance :initarg :instance) 
    (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))
-			       (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))
@@ -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))))
-	 ;;;; 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.