+(in-package :lisp-on-lines)
+
+;;;; * Relational Attributes
+
+
+;;;; ** has-a
+
+(defattribute has-a ()
+ ()
+ (:default-properties
+ :has-a nil))
+
+(define-layered-method attribute-value (object (attribute has-a))
+ (meta-model:explode-foreign-key object (slot-name attribute) :nilp t))
+
+(defdisplay ((attribute has-a) object)
+ (let ((args (plist-union (description.properties attribute) (has-a attribute)))
+ (val (attribute-value object attribute)))
+ (when val
+ (setf (getf args :type)
+ 'lol::one-line))
+ (apply #'display* val
+ args)))
+
+
+;;;; ** 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))))
+ (:default-initargs
+ :type 'lol::one-line))
+
+
+(define-layered-method
+ attribute-value (object (has-many has-many))
+ (slot-value object (slot-name has-many)))
+
+(defdisplay ((attribute has-many) object)
+ ;
+ ;(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label attribute))
+
+ (<:div :style "clear:both;"
+ (let* ((i (apply #'sort (slot-value object (slot-name attribute))
+ (sort-arguments attribute))))
+ (<:ul
+ (dolist* (x i)
+ (<:li (display* x
+ :type 'lol::one-line
+ :layers '(+ wrap-link - label-attributes))))))))
+