minor updates to work with released ucw-core
[clinton/lisp-on-lines.git] / src / standard-descriptions / t.lisp
CommitLineData
4358148e 1(in-package :lisp-on-lines)
2
3(define-description T ()
bd9c9c31 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)
b1c8f43b 12 (type :label "Type" :function #'type-of)
6de8d300 13 (class :label "Class" :function #'class-of)
14 (active-attributes :label "Attributes"
15 :value nil
16 :activep nil
b7657b86 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"
bd9c9c31 27 :value nil
28 :activep nil
29 :keyword :deactivate)
f4efa7ff 30 (label-formatter :value (lambda (label)
b1c8f43b 31 (generic-format *display* "~A:" label))
f4efa7ff 32 :activep nil)
33 (value-formatter :value (curry #'format nil "~A")
34 :activep nil)))
4358148e 35
36(define-layered-method description-of (any-lisp-object)
37 (find-description 't))
38
b7657b86 39(define-layered-function display-attribute (attribute)
40 (:method (attribute)
41 (display-using-description attribute *display* (attribute-object attribute))))
e8d4fa45 42
2548f054 43
b7657b86 44(define-layered-function display-attribute-label (attribute)
45 (:method (attribute)
f4efa7ff 46 (funcall (attribute-label-formatter attribute) (attribute-label attribute))))
47
b7657b86 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)))
46440824 55
56
e8d4fa45 57 (let ((val (attribute-value attribute)))
46440824 58#+nil (break "display Attribute value: ~A with object ~A ~% Description ~A att-d ~A ~% VALUE ~A display on ~A"
59 attribute
60 (attribute-object attribute)
61 *description*
62 (attribute-description attribute)
63 val
64 *display*
65 )
2548f054 66 (if (and (not (slot-boundp attribute 'active-attributes))
46440824 67 (equal val (attribute-object attribute)))
68 (progn (generic-format *display* "~A"(funcall (attribute-value-formatter attribute) val))
69 #+nil(break "using generic format because val is object and there is no active attributes."))
70
e8d4fa45 71 (with-active-descriptions (inline)
2548f054 72 (cond ((slot-value attribute 'value-formatter)
46440824 73 (generic-format *display* "~A"(funcall (attribute-value-formatter attribute) val)))
2548f054 74 ((slot-boundp attribute 'active-attributes)
75 (disp val :attributes (slot-value attribute 'active-attributes)))
76 (t
77 (disp val)))))))))
e8d4fa45 78
79(define-layered-method display-using-description
80 ((attribute standard-attribute) display object &rest args)
81 (declare (ignore args))
82 (when (attribute-label attribute)
b7657b86 83 (display-attribute-label attribute))
84 (display-attribute-value attribute))
e8d4fa45 85
2548f054 86(define-layered-method display-attribute :around
87 ((attribute standard-attribute))
88 (funcall-with-layer-context
89 (modify-layer-context (current-layer-context)
90 :activate (attribute-active-descriptions attribute)
91 :deactivate (attribute-inactive-descriptions attribute))
92 (lambda ()
93 (call-next-method))))
94
95(define-layered-method display-attribute :before
96 ((attribute standard-attribute))
46440824 97#+nil (break "Attribute : ~A with object ~A ~% Description ~A att-d ~A"
98 attribute
99 (attribute-object attribute)
100 *description*
101 (attribute-description attribute)
102))
2548f054 103
4358148e 104(define-display ((description t))
b7657b86 105 (let ((attributes (attributes description)))
106 (display-attribute (first attributes))
f4efa7ff 107 (dolist (attribute (rest attributes) (values))
b7657b86 108 (generic-format *display*
109 (attribute-value
110 (find-attribute description 'attribute-delimiter)))
111 (display-attribute attribute))))
112
113
f4efa7ff 114(define-display :around ((description t) (display null) object)
115 (with-output-to-string (*standard-output*)
b1c8f43b 116 (call-next-layered-method description t object))
117)
b7657b86 118
4358148e 119
6de8d300 120
121