(in-package :lisp-on-lines)
+(defmethod described-object ((attribute standard-attribute))
+ (described-object (attribute-description attribute)))
+
(define-description T ()
- ((identity :label nil :function #'identity)
- (type :label "Type of" :function #'type-of)
+ ((label :label nil
+ :function (lambda (object)
+ (format nil "~@(~A~)"
+ (substitute #\Space #\-
+ (symbol-name
+ (class-name (class-of
+ object)))))))
+ (identity :label nil :function #'identity)
+ (type :label "Type" :function #'type-of)
(class :label "Class" :function #'class-of)
(active-attributes :label "Attributes"
:value nil
:activep nil
:keyword :activate)
(inactive-descriptions :label "Inactive Descriptions"
- :value nil
- :activep nil
- :keyword :deactivate)
- (label-formatter :value (curry #'format nil "~A "))
- (value-formatter :value (curry #'format nil "~A"))))
+ :value nil
+ :activep nil
+ :keyword :deactivate)
+ (label-formatter :value (lambda (label)
+ (generic-format *display* "~A:" label))
+ :activep nil)
+ (value-formatter :value (curry #'format nil "~A")
+ :activep nil)))
(define-layered-method description-of (any-lisp-object)
(find-description 't))
(:method (attribute)
(display-using-description attribute *display* (attribute-object attribute))))
+
(define-layered-function display-attribute-label (attribute)
(:method (attribute)
- (princ (funcall (attribute-label-formatter attribute) (attribute-label attribute))
- *display*)))
-
-
+ (funcall (attribute-label-formatter attribute) (attribute-label attribute))))
+
(define-layered-function display-attribute-value (attribute)
+ (:method-combination arnesi:wrapping-standard)
(:method (attribute)
(flet ((disp (val &rest args)
(apply #'display *display* val
:activate (attribute-active-descriptions attribute)
:deactivate (attribute-inactive-descriptions attribute)
args)))
-
+
+
(let ((val (attribute-value attribute)))
- (if (eql val (attribute-object attribute))
- (generic-format *display* (funcall (attribute-value-formatter attribute) val))
+#+nil (break "display Attribute value: ~A with object ~A ~% Description ~A att-d ~A ~% VALUE ~A display on ~A"
+ attribute
+ (attribute-object attribute)
+ *description*
+ (attribute-description attribute)
+ val
+ *display*
+ )
+ (if (and (not (slot-boundp attribute 'active-attributes))
+ (equal val (attribute-object attribute)))
+ (progn (generic-format *display* "~A"(funcall (attribute-value-formatter attribute) val))
+ #+nil(break "using generic format because val is object and there is no active attributes."))
+
(with-active-descriptions (inline)
- (if (slot-boundp attribute 'active-attributes)
- (disp val :attributes (slot-value attribute 'active-attributes))
- (disp val))))))))
+ (cond ((slot-value attribute 'value-formatter)
+ (generic-format *display* "~A"(funcall (attribute-value-formatter attribute) val)))
+ ((slot-boundp attribute 'active-attributes)
+ (disp val :attributes (slot-value attribute 'active-attributes)))
+ (t
+ (disp val)))))))))
(define-layered-method display-using-description
((attribute standard-attribute) display object &rest args)
(display-attribute-label attribute))
(display-attribute-value attribute))
+(define-layered-method display-attribute :around ((attribute standard-attribute))
+ (with-attribute-context (attribute)
+ (call-next-method))
+ #+nil(funcall-with-layer-context
+ (modify-layer-context (current-layer-context)
+ :activate (attribute-active-descriptions attribute)
+ :deactivate (attribute-inactive-descriptions attribute))
+ (lambda ()
+ (call-next-method))))
+
+(define-layered-method display-attribute :before
+ ((attribute standard-attribute))
+#+nil (break "Attribute : ~A with object ~A ~% Description ~A att-d ~A"
+ attribute
+ (attribute-object attribute)
+ *description*
+ (attribute-description attribute)
+))
+
(define-display ((description t))
(let ((attributes (attributes description)))
- (display-attribute (first attributes))
- (dolist (attribute (rest attributes))
+ (when (first attributes)(display-attribute (first attributes)))
+ (dolist (attribute (rest attributes) (values))
(generic-format *display*
(attribute-value
(find-attribute description 'attribute-delimiter)))
(display-attribute attribute))))
-(define-display :around ((description t) (display null))
- (with-output-to-string (*display*)
- (print (call-next-method) *display*)))
+(define-display :around ((description t) (display null) object)
+ (with-output-to-string (*standard-output*)
+ (apply #'call-next-layered-method description t object args)))
+