((direct-attributes
:accessor attribute-direct-attributes)
(attribute-object
- :accessor attribute-object)
+ :accessor slot-definition-attribute-object)
(attribute-object-initargs
:accessor attribute-object-initargs)))
(:method (description attribute-name property-name)
(ensure-layered-function
(defining-description
- (intern (format nil "~A-~A-~A"
+ (intern (format nil "=PROPERTY-ACCESS-FUNCTION-FOR-~A->~A.~A="
(description-print-name description)
attribute-name
property-name)))
:lambda-list '(description))))
-(define-layered-class standard-attribute ()
- ((description-class :initarg description-class)
+(defvar *init-time-description* nil)
+
+(defmethod attribute-description :around (attribute)
+ (handler-case (call-next-method)
+ (unbound-slot ()
+ (or
+ *init-time-description*
+ (call-next-method)))))
+
+(define-layered-class attribute ()
+ ((description :initarg :description
+ :accessor attribute-description)
(name
:layered-accessor attribute-name
:initarg :name)
(attribute-class
:accessor attribute-class
:initarg :attribute-class
- :initform 'standard-attribute
+ :initform 'standard-attribute)
+ (keyword
+ :layered-accessor attribute-keyword
+ :initarg :keyword
+ :initform nil
:layered t)
- (label
+ (object
+ :layered-accessor attribute-object
+ :accessor described-object
+ :special t)))
+
+
+(define-layered-class standard-attribute (attribute)
+ ((label
:layered-accessor attribute-label
:initarg :label
:initform nil
:layered t
:special t)
+ (label-formatter
+ :layered-accessor attribute-label-formatter
+ :initarg :label-formatter
+ :initform nil
+ :layered t
+ :special t)
(function
:initarg :function
:layered-accessor attribute-function
:layered t
:special t)
- (value
- :layered-accessor %attribute-value
- :initarg :value
- :layered t
- :special t)
+ (value
+ :layered-accessor attribute-value
+ :initarg :value
+ :layered t
+ :special t)
+ (value-formatter
+ :layered-accessor attribute-value-formatter
+ :initarg :value-formatter
+ :initform nil
+ :layered t
+ :special t)
(activep
:layered-accessor attribute-active-p
- :initarg :activep
+ :initarg :activep ;depreciated
+ :initarg :active
:initform t
:layered t
- :special t)
- (keyword
- :layered-accessor attribute-keyword
- :initarg :keyword
- :initform nil
- :layered t)
-))
+ :special t
+ :documentation
+ "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.")
+ (active-attributes :layered-accessor attribute-active-attributes
+ :initarg :attributes
+ :layered t
+ :special t)
+ (active-descriptions :layered-accessor attribute-active-descriptions
+ :initarg :activate
+ :initform nil
+ :layered t
+ :special t)
+ (inactive-descriptions :layered-accessor attribute-inactive-descriptions
+ :initarg :deactivate
+ :initform nil
+ :layered t
+ :special t)))
+
+(define-layered-method attribute-active-p :around (attribute)
+ (let ((active? (call-next-method)))
+ (if (eq :when active?)
+ (not (null (attribute-value attribute)))
+ active?)))
+
+(define-layered-method attribute-label-formatter :around (attribute)
+ (or (slot-value attribute 'label-formatter)
+ (attribute-value (find-attribute (attribute-description attribute) 'label-formatter))
+ (error "No Formatter .. fool!")))
+
+(define-layered-method attribute-value-formatter :around (attribute)
+
+ (or (slot-value attribute 'value-formatter)
+ (attribute-value (find-attribute (attribute-description attribute) 'value-formatter))
+ (error "No Formatter .. fool!")))
+
+
+
+(define-layered-method attribute-object ((attribute standard-attribute))
+ (if (slot-boundp attribute 'object)
+ (call-next-method)
+ (described-object (attribute-description attribute))))
+
+
+(define-layered-function attribute-value-using-object (object attribute))
+(define-layered-function (setf attribute-value-using-object) (value object attribute))
+
+(define-layered-method attribute-value ((attribute standard-attribute))
+ (attribute-value-using-object (attribute-object attribute) attribute))
+
+(define-layered-method attribute-value-using-object (object attribute)
+ (let ((fn (handler-case (attribute-function attribute)
+ (unbound-slot () nil))))
+ (if fn
+ (funcall fn object)
+ (slot-value attribute 'value))))
+
+(define-layered-method (setf attribute-value) (value (attribute standard-attribute))
+ (setf (attribute-value-using-object (attribute-object attribute) attribute) value))
+
+(define-layered-method (setf attribute-value-using-object) (value object attribute)
+ (error "No (SETF ATTRIBUTE-VALUE-USING-OBJECT) for ~A ~A and we are not editable"
+ object attribute))
+
(defun ensure-access-function (class attribute property)
(with-function-access
(with-function-access
(slot-value-using-class class attribute property))
(funcall fn layer (attribute-description attribute)))
- (funcall fn layer (attribute-description attribute))))))
+ (handler-case (funcall fn layer (attribute-description attribute))
+ (error ()
+ (warn "Error calling ~A" fn)))))))
- (define-layered-function attribute-value (object attribute))
-
- (define-layered-method attribute-value (object attribute)
-
- (let ((fn (handler-case (attribute-function attribute)
- (unbound-slot () nil))))
- (if fn
- (funcall fn object)
- (%attribute-value attribute))))
-
-(defmethod attribute-description (attribute)
- ;(break "description for ~A is (slot-value attribute 'description-name)")
- (find-layer (slot-value attribute 'description-class))
- #+nil (let ((name (slot-value attribute 'description-name)))
- (when name
- (find-description name))))
(:method ((attribute standard-attribute) initarg)
nil)
(:method ((attribute standard-attribute) (initarg (eql :function)))
+ t)
+ (:method ((attribute standard-attribute) (initarg (eql :value)))
t))
(defun prepare-initargs (att args)
(attribute-value *object* attribute))
(defmacro with-attributes (names description &body body)
- `(with-slots ,names ,description ,@body))
-
-(define-layered-function display-attribute (object attribute)
- (:method (object attribute)
- (display-using-description attribute *display* object)))
-
-(define-layered-function display-attribute-label (object attribute)
- (:method (object attribute)
- (format *display* "~A " (attribute-label attribute))
-))
-
-(define-layered-function display-attribute-value (object attribute)
- (:method (object attribute)
- (let ((val (attribute-value object attribute)))
- (if (eq val object)
- (format *display* "~A " val)
- (with-active-descriptions (inline)
- (display *display* val )
-
- )
- ))))
-
-(define-layered-method display-using-description
- ((attribute standard-attribute) display object &rest args)
- (declare (ignore args))
- (when (attribute-label attribute)
- (display-attribute-label object attribute))
- (display-attribute-value object attribute))
+ `(let ,(loop for name in names collect
+ (list name `(find-attribute ,description ',name)))
+ ,@body))
+
+
HCoop / clinton / lisp-on-lines.git / blobdiff