Support `:activate ((DESC . SPECIAL-INITARGS))' in attributes
[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 ((attribute standard-attribute))
91 (with-attribute-context (attribute)
92 (call-next-method))
93 #+nil(funcall-with-layer-context
94 (modify-layer-context (current-layer-context)
95 :activate (attribute-active-descriptions attribute)
96 :deactivate (attribute-inactive-descriptions attribute))
97 (lambda ()
98 (call-next-method))))
99
100 (define-layered-method display-attribute :before
101 ((attribute standard-attribute))
102 #+nil (break "Attribute : ~A with object ~A ~% Description ~A att-d ~A"
103 attribute
104 (attribute-object attribute)
105 *description*
106 (attribute-description attribute)
107 ))
108
109 (define-display ((description t))
110 (let ((attributes (attributes description)))
111 (when (first attributes)(display-attribute (first attributes)))
112 (dolist (attribute (rest attributes) (values))
113 (generic-format *display*
114 (attribute-value
115 (find-attribute description 'attribute-delimiter)))
116 (display-attribute attribute))))
117
118
119 (define-display :around ((description t) (display null) object)
120 (with-output-to-string (*standard-output*)
121 (apply #'call-next-layered-method description t object args)))
122
123
124
125
126