32569038ca86be6f0d3e71af9c01179f2ea2d49c
[clinton/lisp-on-lines.git] / src / standard-descriptions / t.lisp
1 (in-package :lisp-on-lines)
2
3 (defmethod described-object ((attribute standard-attribute))
4 (described-object (attribute-description attribute)))
5
6 (define-description T ()
7 ((label :label nil
8 :function (lambda (object)
9 (format nil "~@(~A~)"
10 (substitute #\Space #\-
11 (symbol-name
12 (class-name (class-of
13 object)))))))
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"
18 :value nil
19 :activep nil
20 :keyword :attributes)
21 (attribute-delimiter :label "Attribute Delimiter"
22 :value "~%"
23 :activep nil
24 :keyword :delimter)
25 (active-descriptions :label "Active Descriptions"
26 :value nil
27 :activep nil
28 :keyword :activate)
29 (inactive-descriptions :label "Inactive Descriptions"
30 :value nil
31 :activep nil
32 :keyword :deactivate)
33 (label-formatter :value (lambda (label)
34 (generic-format *display* "~A:" label))
35 :activep nil)
36 (value-formatter :value (curry #'format nil "~A")
37 :activep nil)))
38
39 (define-layered-method description-of (any-lisp-object)
40 (find-description 't))
41
42 (define-layered-function display-attribute (attribute)
43 (:method (attribute)
44 (display-using-description attribute *display* (attribute-object attribute))))
45
46
47 (define-layered-function display-attribute-label (attribute)
48 (:method (attribute)
49 (funcall (attribute-label-formatter attribute) (attribute-label attribute))))
50
51 (define-layered-function display-attribute-value (attribute)
52 (:method-combination arnesi:wrapping-standard)
53 (:method (attribute)
54 (flet ((disp (val &rest args)
55 (apply #'display *display* val
56 :activate (attribute-active-descriptions attribute)
57 :deactivate (attribute-inactive-descriptions attribute)
58 args)))
59
60
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"
63 attribute
64 (attribute-object attribute)
65 *description*
66 (attribute-description attribute)
67 val
68 *display*
69 )
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."))
74
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)))
80 (t
81 (disp val)))))))))
82
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))
89
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))
96 (lambda ()
97 (call-next-method))))
98
99 (define-layered-method display-attribute :before
100 ((attribute standard-attribute))
101 #+nil (break "Attribute : ~A with object ~A ~% Description ~A att-d ~A"
102 attribute
103 (attribute-object attribute)
104 *description*
105 (attribute-description attribute)
106 ))
107
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*
113 (attribute-value
114 (find-attribute description 'attribute-delimiter)))
115 (display-attribute attribute))))
116
117
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)))
121
122
123
124
125