1 (in-package :lisp-on-lines
)
3 (defmethod described-object ((attribute standard-attribute
))
4 (described-object (attribute-description attribute
)))
6 (define-description T
()
8 :function
(lambda (object)
10 (substitute #\Space
#\-
14 (identity :label nil
:function
#'identity
)
15 (type :label
"Type" :function
#'type-of
)
16 (class :label
"Class" :function
#'class-of
)
17 (active-attributes :label
"Attributes"
21 (attribute-delimiter :label
"Attribute Delimiter"
25 (active-descriptions :label
"Active Descriptions"
29 (inactive-descriptions :label
"Inactive Descriptions"
33 (label-formatter :value
(lambda (label)
34 (generic-format *display
* "~A:" label
))
36 (value-formatter :value
(curry #'format nil
"~A")
39 (define-layered-method description-of
(any-lisp-object)
40 (find-description 't
))
42 (define-layered-function display-attribute
(attribute)
44 (display-using-description attribute
*display
* (attribute-object attribute
))))
47 (define-layered-function display-attribute-label
(attribute)
49 (funcall (attribute-label-formatter attribute
) (attribute-label attribute
))))
51 (define-layered-function display-attribute-value
(attribute)
52 (:method-combination arnesi
:wrapping-standard
)
54 (flet ((disp (val &rest args
)
55 (apply #'display
*display
* val
56 :activate
(attribute-active-descriptions attribute
)
57 :deactivate
(attribute-inactive-descriptions attribute
)
61 (let ((val (attribute-value attribute
)))
62 #+nil
(break "display Attribute value: ~A with object ~A ~% Description ~A att-d ~A ~% VALUE ~A display on ~A"
64 (attribute-object attribute
)
66 (attribute-description attribute
)
70 (if (and (not (slot-boundp attribute
'active-attributes
))
71 (equal val
(attribute-object attribute
)))
72 (progn (generic-format *display
* "~A"(funcall (attribute-value-formatter attribute
) val
))
73 #+nil
(break "using generic format because val is object and there is no active attributes."))
75 (with-active-descriptions (inline)
76 (cond ((slot-value attribute
'value-formatter
)
77 (generic-format *display
* "~A"(funcall (attribute-value-formatter attribute
) val
)))
78 ((slot-boundp attribute
'active-attributes
)
79 (disp val
:attributes
(slot-value attribute
'active-attributes
)))
83 (define-layered-method display-using-description
84 ((attribute standard-attribute
) display object
&rest args
)
85 (declare (ignore args
))
86 (when (attribute-label attribute
)
87 (display-attribute-label attribute
))
88 (display-attribute-value attribute
))
90 (define-layered-method display-attribute
:around
91 ((attribute standard-attribute
))
92 (funcall-with-layer-context
93 (modify-layer-context (current-layer-context)
94 :activate
(attribute-active-descriptions attribute
)
95 :deactivate
(attribute-inactive-descriptions attribute
))
99 (define-layered-method display-attribute
:before
100 ((attribute standard-attribute
))
101 #+nil
(break "Attribute : ~A with object ~A ~% Description ~A att-d ~A"
103 (attribute-object attribute
)
105 (attribute-description attribute
)
108 (define-display ((description t
))
109 (let ((attributes (attributes description
)))
110 (when (first attributes
)(display-attribute (first attributes
)))
111 (dolist (attribute (rest attributes
) (values))
112 (generic-format *display
*
114 (find-attribute description
'attribute-delimiter
)))
115 (display-attribute attribute
))))
118 (define-display :around
((description t
) (display null
) object
)
119 (with-output-to-string (*standard-output
*)
120 (apply #'call-next-layered-method description t object args
)))