From: Drew Crampsie <drewc@tech.coop>
Date: Mon, 16 Jan 2006 09:42:51 +0000 (-0800)
Subject: has-many attribute added.. getting ther.
X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/commitdiff_plain/91f2ab7b92b3a1c3c7e419ce15843e1126755e99?hp=60a24293adb9a76f8530175efb05e24a7f953e42;ds=sidebyside

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
--- 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))
-	finally (return plist)))
+	finally (return plist))
+  plist)
 
 (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)
-  (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
-	  ;;;; 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
-	  #+ (or) ,@ (cdr args) )
+	  #+ (or) ,@ (cdr args)
+	  (:default-initargs :plist (list ,@properties)))
       (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)
-  (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)) 
-		 :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"
@@ -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-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
--- 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)
@@ -15,7 +36,9 @@
 
 
 (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))
diff --git a/src/standard-display.lisp b/src/standard-display.lisp
index 9bcf3ff..cc0b897 100644
--- 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"
-		      (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