1 (in-package :lisp-on-lines
)
3 (define-description T
()
4 ((identity :label nil
:function
#'identity
)
5 (type :label
"Type of" :function
#'type-of
)
6 (class :label
"Class" :function
#'class-of
)
7 (active-attributes :label
"Attributes"
11 (attribute-delimiter :label
"Attribute Delimiter"
15 (active-descriptions :label
"Active Descriptions"
19 (inactive-descriptions :label
"Inactive Descriptions"
23 (label-formatter :value
(curry #'format nil
"~A "))
24 (value-formatter :value
(curry #'format nil
"~A"))))
26 (define-layered-method description-of
(any-lisp-object)
27 (find-description 't
))
29 (define-layered-function display-attribute
(attribute)
31 (display-using-description attribute
*display
* (attribute-object attribute
))))
33 (define-layered-function display-attribute-label
(attribute)
35 (princ (funcall (attribute-label-formatter attribute
) (attribute-label attribute
))
39 (define-layered-function display-attribute-value
(attribute)
41 (flet ((disp (val &rest args
)
42 (apply #'display
*display
* val
43 :activate
(attribute-active-descriptions attribute
)
44 :deactivate
(attribute-inactive-descriptions attribute
)
47 (let ((val (attribute-value attribute
)))
48 (if (eql val
(attribute-object attribute
))
49 (generic-format *display
* (funcall (attribute-value-formatter attribute
) val
))
50 (with-active-descriptions (inline)
51 (if (slot-boundp attribute
'active-attributes
)
52 (disp val
:attributes
(slot-value attribute
'active-attributes
))
55 (define-layered-method display-using-description
56 ((attribute standard-attribute
) display object
&rest args
)
57 (declare (ignore args
))
58 (when (attribute-label attribute
)
59 (display-attribute-label attribute
))
60 (display-attribute-value attribute
))
62 (define-display ((description t
))
63 (let ((attributes (attributes description
)))
64 (display-attribute (first attributes
))
65 (dolist (attribute (rest attributes
))
66 (generic-format *display
*
68 (find-attribute description
'attribute-delimiter
)))
69 (display-attribute attribute
))))
72 (define-display :around
((description t
) (display null
))
73 (with-output-to-string (*display
*)
74 (print (call-next-method) *display
*)))