beginnings of a test component.

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

diff --git a/src/mewa.lisp b/src/mewa.lisp
index 850ece6..c8fe7a5 100644 (file)
--- a/src/mewa.lisp
+++ b/src/mewa.lisp
@@ -22,7 +22,8 @@ in both PLIST and NEW-PROPS get the value in NEW-PROPS.
 The other properties in PLIST are left untouched."
   (loop for cons on new-props by #'cddr
        do (setf (getf plist (first cons)) (second cons))
 The other properties in PLIST are left untouched."
   (loop for cons on new-props by #'cddr
        do (setf (getf plist (first cons)) (second cons))

-       finally (return plist)))
+       finally (return plist))
+  plist)

 
 (defun plist-union (new-props plist)
   "Non-destructive version of plist-nunion"
 
 (defun plist-union (new-props plist)
   "Non-destructive version of plist-nunion"


@@ -71,18 +72,20 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
     standard-attribute ()
     ((name :layered-accessor attribute.name :initarg :name :initform "attribute")
      (type :layered-accessor attribute.type :initarg :type :initform t :type symbol)
     standard-attribute ()
     ((name :layered-accessor attribute.name :initarg :name :initform "attribute")
      (type :layered-accessor attribute.type :initarg :type :initform t :type symbol)

-     (plist :layered-accessor attribute.plist :initarg :plist :initform nil))
+     (properties :layered-accessor attribute.properties :initarg :properties :initform nil))

     (:documentation "Attributes are used to display a part of a thing, such as a slot of an object, a text label, the car of a list, etc."))
 
 (defmacro defattribute (name supers slots &rest args)
     (:documentation "Attributes are used to display a part of a thing, such as a slot of an object, a text label, the car of a list, etc."))
 
 (defmacro defattribute (name supers slots &rest args)

-  (let ((type (or (second (assoc :type-name args)) name) ))
+  (let ((type (or (second (assoc :type-name args)) name))
+       (properties (cdr (assoc :default-properties args))))

     `(progn
       
       (define-layered-class
     `(progn
       
       (define-layered-class

-         ;;;; TODO: naive way of making sure s-a is a superclass
+         ;;;; TODO: fix the naive way of making sure s-a is a superclass

          ,name ,(or supers '(standard-attribute))
          ,slots
          ,name ,(or supers '(standard-attribute))
          ,slots

-         #+ (or) ,@ (cdr args) )
+         #+ (or) ,@ (cdr args)
+         (:default-initargs :properties (list ,@properties)))

       (defmethod find-attribute-class-for-type ((type (eql ',type)))
        ',name))))
 
       (defmethod find-attribute-class-for-type ((type (eql ',type)))
        ',name))))
 


@@ -110,15 +113,18 @@ using the attributes defined in an occurence. Presentation Attributes are always
       'presentation-attribute
       'standard-attribute))
 
       'presentation-attribute
       'standard-attribute))
 

-(defun make-attribute (&key name type plist)
-  (make-instance (or (find-attribute-class-for-type type)
+(defun make-attribute (&key name type properties)
+  (let ((i (make-instance (or (find-attribute-class-for-type type)

                     (find-attribute-class-for-name name)) 
                     (find-attribute-class-for-name name)) 

-                :name name :type type :plist plist))
+                :name name :type type)))
+    (setf (attribute.properties i)
+         (plist-union properties (attribute.properties i)))
+    i)) 

 
 

-(defmethod ensure-attribute ((occurence standard-occurence) name type plist)
+(defmethod ensure-attribute ((occurence standard-occurence) name type properties)

   "Creates an attribute in the given occurence"
   (setf (gethash name (attribute-map occurence))
   "Creates an attribute in the given occurence"
   (setf (gethash name (attribute-map occurence))

-       (make-attribute :name name :type type :plist plist)))
+       (make-attribute :name name :type type :properties properties)))

 
 (defmethod find-attribute ((occurence standard-occurence) name)
   (gethash name (attribute-map occurence)))
 
 (defmethod find-attribute ((occurence standard-occurence) name)
   (gethash name (attribute-map occurence)))


@@ -127,12 +133,12 @@ using the attributes defined in an occurence. Presentation Attributes are always
   (loop for att being the hash-values of (attribute-map occurence)
        collect att))
 
   (loop for att being the hash-values of (attribute-map occurence)
        collect att))
 

-(defmethod ensure-attribute (occurence-name name type plist)
+(defmethod ensure-attribute (occurence-name name type properties)

   (ensure-attribute
    (find-occurence occurence-name)
    name
    type
   (ensure-attribute
    (find-occurence occurence-name)
    name
    type

-   plist)) 
+   properties)) 

 
 ;;;; The following functions make up the public interface to the
 ;;;; MEWA Attribute Occurence system.
 
 ;;;; The following functions make up the public interface to the
 ;;;; MEWA Attribute Occurence system.


@@ -153,13 +159,13 @@ using the attributes defined in an occurence. Presentation Attributes are always
        (if (and att inherit) 
            (cons (car definition) 
                  (plist-union (cdr definition)
        (if (and att inherit) 
            (cons (car definition) 
                  (plist-union (cdr definition)

-                        (attribute.plist att)))
+                        (attribute.properties att)))

            definition)))) 
 
 (defmethod set-attribute-properties ((occurence-name t) attribute properties)
   (let ((a (find-attribute occurence-name attribute)))
     (if a
            definition)))) 
 
 (defmethod set-attribute-properties ((occurence-name t) attribute properties)
   (let ((a (find-attribute occurence-name attribute)))
     (if a

-       (setf (attribute.plist a) (plist-nunion properties (attribute.plist a)))
+       (setf (attribute.properties a) (plist-nunion properties (attribute.properties a)))

        (error "Attribute ~A does not exist" attribute))))
 
 (defmethod perform-define-attributes ((occurence-name t) attributes)
        (error "Attribute ~A does not exist" attribute))))
 
 (defmethod perform-define-attributes ((occurence-name t) attributes)


@@ -181,8 +187,8 @@ using the attributes defined in an occurence. Presentation Attributes are always
 
 (defmethod setter (attribute)
   (warn "Setting ~A in ~A" attribute *context*)
 
 (defmethod setter (attribute)
   (warn "Setting ~A in ~A" attribute *context*)

-  (let ((setter (getf (attribute.plist attribute) :setter))
-       (slot-name (getf (attribute.plist attribute) :slot-name)))
+  (let ((setter (getf (attribute.properties attribute) :setter))
+       (slot-name (getf (attribute.properties attribute) :slot-name)))

     (cond (setter
           setter)
          (slot-name
     (cond (setter
           setter)
          (slot-name


@@ -193,8 +199,8 @@ using the attributes defined in an occurence. Presentation Attributes are always
             (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute))))))
     
 (defmethod getter (attribute)
             (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute))))))
     
 (defmethod getter (attribute)

-  (let ((getter (getf (attribute.plist attribute) :getter))
-       (slot-name (getf (attribute.plist attribute) :slot-name)))
+  (let ((getter (getf (attribute.properties attribute) :getter))
+       (slot-name (getf (attribute.properties attribute) :slot-name)))

     (cond (getter
           getter)
          (slot-name
     (cond (getter
           getter)
          (slot-name


@@ -206,8 +212,6 @@ using the attributes defined in an occurence. Presentation Attributes are always
 (define-layered-function attribute-value (instance attribute)
   (:documentation " Like SLOT-VALUE for instances, the base method calls GETTER."))
 
 (define-layered-function attribute-value (instance attribute)
   (:documentation " Like SLOT-VALUE for instances, the base method calls GETTER."))
 

-
-

 (define-layered-method attribute-value (instance (attribute standard-attribute))
   (funcall (getter attribute) instance))
 
 (define-layered-method attribute-value (instance (attribute standard-attribute))
   (funcall (getter attribute) instance))
 


@@ -253,7 +257,7 @@ using the attributes defined in an occurence. Presentation Attributes are always
 (defun attribute-to-definition (attribute)
   (nconc (list (attribute.name attribute)
               (attribute.type attribute))
 (defun attribute-to-definition (attribute)
   (nconc (list (attribute.name attribute)
               (attribute.type attribute))

-        (attribute.plist attribute)))
+        (attribute.properties attribute)))

 
 (defun find-default-presentation-attribute-definitions ()
   (if (eql *default-attributes-class-name* 'default)
 
 (defun find-default-presentation-attribute-definitions ()
   (if (eql *default-attributes-class-name* 'default)


@@ -354,7 +358,7 @@ using the attributes defined in an occurence. Presentation Attributes are always
                                            plist
                                            (plist-union
                                             (global-properties parent-presentation)
                                            plist
                                            (plist-union
                                             (global-properties parent-presentation)

-                                            (attribute.plist attribute)))
+                                            (attribute.properties attribute)))

                                           (list :size 30 :parent parent-presentation))))))
 
 (defmethod find-applicable-attributes-using-attribute-list (occurence attribute-list)
                                           (list :size 30 :parent parent-presentation))))))
 
 (defmethod find-applicable-attributes-using-attribute-list (occurence attribute-list)


@@ -435,7 +439,7 @@ in that object presentation."
                       (attribute.type a)
                       type) 
                   (plist-union initargs (when a
                       (attribute.type a)
                       type) 
                   (plist-union initargs (when a

-                                          (attribute.plist a))))))
+                                          (attribute.properties a))))))

     
     (setf (slot-value i 'instance) object)
     (initialize-slots i)
     
     (setf (slot-value i 'instance) object)
     (initialize-slots i)