Add NULL description
[clinton/lisp-on-lines.git] / src / standard-descriptions / t.lisp
1 (in-package :lisp-on-lines)
2
3 (define-description T ()
4 ((label :label nil
5 :function (lambda (object)
6 (format nil "~@(~A~)"
7 (substitute #\Space #\-
8 (symbol-name
9 (class-name (class-of
10 object)))))))
11 (identity :label nil :function #'identity)
12 (type :label "Type" :function #'type-of)
13 (class :label "Class" :function #'class-of)
14 (active-attributes :label "Attributes"
15 :value nil
16 :activep nil
17 :keyword :attributes)
18 (attribute-delimiter :label "Attribute Delimiter"
19 :value "~%"
20 :activep nil
21 :keyword :delimter)
22 (active-descriptions :label "Active Descriptions"
23 :value nil
24 :activep nil
25 :keyword :activate)
26 (inactive-descriptions :label "Inactive Descriptions"
27 :value nil
28 :activep nil
29 :keyword :deactivate)
30 (label-formatter :value (lambda (label)
31 (generic-format *display* "~A:" label))
32 :activep nil)
33 (value-formatter :value (curry #'format nil "~A")
34 :activep nil)))
35
36 (define-layered-method description-of (any-lisp-object)
37 (find-description 't))
38
39 (define-layered-function display-attribute (attribute)
40 (:method (attribute)
41 (display-using-description attribute *display* (attribute-object attribute))))
42
43
44 (define-layered-function display-attribute-label (attribute)
45 (:method (attribute)
46 (funcall (attribute-label-formatter attribute) (attribute-label attribute))))
47
48 (define-layered-function display-attribute-value (attribute)
49 (:method (attribute)
50 (flet ((disp (val &rest args)
51 (apply #'display *display* val
52 :activate (attribute-active-descriptions attribute)
53 :deactivate (attribute-inactive-descriptions attribute)
54 args)))
55
56 (let ((val (attribute-value attribute)))
57 (if (and (not (slot-boundp attribute 'active-attributes))
58 (eql val (attribute-object attribute)))
59 (generic-format *display* (funcall (attribute-value-formatter attribute) val))
60 (with-active-descriptions (inline)
61 (cond ((slot-value attribute 'value-formatter)
62 (generic-format *display* (funcall (attribute-value-formatter attribute) val)))
63 ((slot-boundp attribute 'active-attributes)
64 (disp val :attributes (slot-value attribute 'active-attributes)))
65 (t
66 (disp val)))))))))
67
68 (define-layered-method display-using-description
69 ((attribute standard-attribute) display object &rest args)
70 (declare (ignore args))
71 (when (attribute-label attribute)
72 (display-attribute-label attribute))
73 (display-attribute-value attribute))
74
75 (define-layered-method display-attribute :around
76 ((attribute standard-attribute))
77 (funcall-with-layer-context
78 (modify-layer-context (current-layer-context)
79 :activate (attribute-active-descriptions attribute)
80 :deactivate (attribute-inactive-descriptions attribute))
81 (lambda ()
82 (call-next-method))))
83
84 (define-layered-method display-attribute :before
85 ((attribute standard-attribute))
86 )
87
88 (define-display ((description t))
89 (let ((attributes (attributes description)))
90 (display-attribute (first attributes))
91 (dolist (attribute (rest attributes) (values))
92 (generic-format *display*
93 (attribute-value
94 (find-attribute description 'attribute-delimiter)))
95 (display-attribute attribute))))
96
97
98 (define-display :around ((description t) (display null) object)
99 (with-output-to-string (*standard-output*)
100 (call-next-layered-method description t object))
101 )
102
103
104
105