X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/d2dbe50f3600d000fb2fe294579f21a00dde99e8..fc3e754fa505c6f725ebe962917eabc1dc8f8ce2:/src/mewa/mewa.lisp diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp index 045b7c1..e620130 100644 --- a/src/mewa/mewa.lisp +++ b/src/mewa/mewa.lisp @@ -9,7 +9,7 @@ number mewa-currency integer mewa-integer currency mewa-currency - generalized-boolean mewa-boolean)) + 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)) @@ -137,8 +154,6 @@ attributes is an alist keyed on the attribute name." ;;;presentations - - (defcomponent mewa () ((instance :accessor instance :initarg :instance) (attributes