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