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"
(: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))))
'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"
(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))
-(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)
(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))