Changes from maxclaims branch (git).
[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
49
50
51 (define-layered-function display-attribute-value (attribute)
52 (:method (attribute)
53 (flet ((disp (val &rest args)
54 (apply #'display *display* val
55 :activate (attribute-active-descriptions attribute)
56 :deactivate (attribute-inactive-descriptions attribute)
57 args)))
58
59 (let ((val (attribute-value attribute)))
60 (if (and (not (slot-boundp attribute 'active-attributes))
61 (eql val (attribute-object attribute)))
62 (generic-format *display* (funcall (attribute-value-formatter attribute) val))
63 (with-active-descriptions (inline)
64 (cond ((slot-value attribute 'value-formatter)
65 (generic-format *display* (funcall (attribute-value-formatter attribute) val)))
66 ((slot-boundp attribute 'active-attributes)
67 (disp val :attributes (slot-value attribute 'active-attributes)))
68 (t
69 (disp val)))))))))
70
71 (define-layered-method display-using-description
72 ((attribute standard-attribute) display object &rest args)
73 (declare (ignore args))
74 (when (attribute-label attribute)
75 (display-attribute-label attribute))
76 (display-attribute-value attribute))
77
78 (define-layered-method display-attribute :around
79 ((attribute standard-attribute))
80 (funcall-with-layer-context
81 (modify-layer-context (current-layer-context)
82 :activate (attribute-active-descriptions attribute)
83 :deactivate (attribute-inactive-descriptions attribute))
84 (lambda ()
85 (call-next-method))))
86
87 (define-layered-method display-attribute :before
88 ((attribute standard-attribute))
89 )
90
91 (define-display ((description t))
92 (let ((attributes (attributes description)))
93 (display-attribute (first attributes))
94 (dolist (attribute (rest attributes) (values))
95 (generic-format *display*
96 (attribute-value
97 (find-attribute description 'attribute-delimiter)))
98 (display-attribute attribute))))
99
100
101 (define-display :around ((description t) (display null) object)
102 (with-output-to-string (*standard-output*)
103 (call-next-layered-method description t object))
104 )
105
106
107
108