X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/6de8d30004efc9337b8c40d2ff2d0a76651d23eb..e8fd1a9a2f3b68a8aee14b8776ff8398ba717eef:/src/attribute.lisp diff --git a/src/attribute.lisp b/src/attribute.lisp index 2b66d42..7273260 100644 --- a/src/attribute.lisp +++ b/src/attribute.lisp @@ -19,7 +19,7 @@ ((direct-attributes :accessor attribute-direct-attributes) (attribute-object - :accessor attribute-object) + :accessor slot-definition-attribute-object) (attribute-object-initargs :accessor attribute-object-initargs))) @@ -41,15 +41,25 @@ (: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) @@ -59,36 +69,116 @@ (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 @@ -200,26 +290,12 @@ (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)))) @@ -231,6 +307,8 @@ (: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) @@ -247,34 +325,11 @@ (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))q + +