has-many attribute added.. getting ther.

darcs-hash:20060116094251-5417e-fe253afd40863595ccb893732acca38c21c01cb5.gz

diff --git a/src/mewa.lisp b/src/mewa.lisp
index 850ece6..292f351 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"


@@ -75,14 +76,16 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
     (: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 :plist (list ,@properties)))

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


@@ -111,9 +114,12 @@ using the attributes defined in an occurence. Presentation Attributes are always
       'standard-attribute))
 
 (defun make-attribute (&key name type plist)
       'standard-attribute))
 
 (defun make-attribute (&key name type plist)

-  (make-instance (or (find-attribute-class-for-type type)
+  (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.plist i)
+         (plist-union plist (attribute.plist i)))
+    i)) 

 
 (defmethod ensure-attribute ((occurence standard-occurence) name type plist)
   "Creates an attribute in the given occurence"
 
 (defmethod ensure-attribute ((occurence standard-occurence) name type plist)
   "Creates an attribute in the given occurence"


@@ -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))
 

diff --git a/src/relational-attributes.lisp b/src/relational-attributes.lisp
index 5485515..d9ba761 100644 (file)
--- a/src/relational-attributes.lisp
+++ b/src/relational-attributes.lisp
@@ -1,4 +1,25 @@
-(in-package :lol)
+(in-package :lisp-on-lines)
+
+;;;; * Relational Attributes
+
+;;;; ** Has-Many attribute
+
+(defattribute has-many ()
+  ()
+  (:default-properties
+      :add-new-label "Add New"
+    :sort-arguments  (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x)))))
+
+
+(defdisplay (:description (attribute has-many))
+    ;
+  (<ucw:submit :action (add-to-has-many slot instance) :value (getp :add-new-label))
+  (let* ((i (apply #'sort (slot-value object (getp :slot-name))
+                 (getp :sort-arguments))))
+    (display component i
+            :type'lol::one-line
+            :layers '(+ wrap-link))))
+

 
 (defun find-many-to-many-class (slot-name instance)
   (let* ((imd (getf (meta-model::find-slot-metadata instance slot-name)
 
 (defun find-many-to-many-class (slot-name instance)
   (let* ((imd (getf (meta-model::find-slot-metadata instance slot-name)


@@ -15,7 +36,9 @@
 
 
 (defdisplay (:description (attribute many-to-many))
 
 
 (defdisplay (:description (attribute many-to-many))

-  (let ((instances (select-instances object t))
+  (<:as-html "ASDASD"))
+
+  #+nil(let ((instances (select-instances object t))

        new-instance)
     (<:ul
      (<:li (<ucw:button :action (add-new-relation component object (getp slot-name))
        new-instance)
     (<:ul
      (<:li (<ucw:button :action (add-new-relation component object (getp slot-name))

diff --git a/src/standard-display.lisp b/src/standard-display.lisp
index 9bcf3ff..cc0b897 100644 (file)
--- a/src/standard-display.lisp
+++ b/src/standard-display.lisp
@@ -154,7 +154,8 @@
                    (attribute (find-attribute occurence (first att))))
               (with-plist ((plist-union (rest att) (find-plist attribute)))
                 (<:p :class "attribute"
                    (attribute (find-attribute occurence (first att))))
               (with-plist ((plist-union (rest att) (find-plist attribute)))
                 (<:p :class "attribute"

-                     (and (getp :show-labels-p) (<:span :class "label" (<:as-html (or (getp :label) "")  " ")))           
+                     (and (o-getp :show-labels-p)
+                          (<:span :class "label" (<:as-html (or (getp :label) "")  " ")))         

                      (display-using-description
                       attribute
                       component
                      (display-using-description
                       attribute
                       component