fixed up display mechanism
[clinton/lisp-on-lines.git] / src / standard-display.lisp
CommitLineData
dee565d0
DC
1(in-package :lisp-on-lines)
2
2b0fd9c8 3;;;; The Standard Layers
dee565d0 4(deflayer viewer)
2b0fd9c8 5(deflayer editor)
a4e6154d 6
e1645f63 7(define-layered-method label (anything)
8 nil)
9
a4e6154d
DC
10(defdisplay
11 :in-layer editor :around (description object)
e1645f63 12 "It is useful to remove the viewer layer when in the editing layer.
a4e6154d 13This allows us to dispatch to a subclasses editor."
e1645f63 14 (with-inactive-layers (viewer)
15 (call-next-method)))
a4e6154d 16
e1645f63 17;;;; These layers affect the layout of the object
dee565d0 18(deflayer one-line)
14a7e1bc 19(deflayer as-table)
2b0fd9c8 20(deflayer as-string)
14a7e1bc 21
2b0fd9c8
DC
22(defdisplay
23 :in-layer as-string (d o)
e1645f63 24 (with-inactive-layers (editor viewer one-line as-table show-attribute-labels)
a4e6154d
DC
25 (do-attributes (a d)
26 (display-attribute a o)
27 (<:as-is " "))))
dee565d0 28
2b0fd9c8
DC
29(defmethod list-slots (thing)
30 (list 'identity))
d1b0ed7c 31
87e47dd6
DC
32;;;; * Object displays.
33
a4e6154d 34
dee565d0 35
2b0fd9c8 36;;;; TODO: all lisp types should have occurences and attributes defined for them.
dee565d0 37
2b0fd9c8
DC
38(defdisplay ((description t) lisp-value)
39 (<:as-html lisp-value))
14a7e1bc 40
2b0fd9c8 41(defdisplay (description (object string))
dee565d0
DC
42 (<:as-html object))
43
2b0fd9c8
DC
44(defdisplay (description object (component t))
45 "The default display for CLOS objects"
46 (print (class-name (class-of object)))
47 (dolist* (slot-name (list-slots object))
48
49 (let ((boundp (slot-boundp object slot-name)))
50 (format t "~A~A : ~A" (strcat slot-name)
51 (if boundp
52 ""
53 "(unbound)")
54 (if boundp
55 (slot-value object slot-name) "")))))
56
57(defdisplay ((description t) object)
58 "The default display for CLOS objects in UCW components"
59 (dolist* (slot-name (list-slots object))
60
61 (let ((boundp (slot-boundp object slot-name)))
62 (<:label :class "lol-label"
63 (display-attribute 'label (strcat slot-name))
64 (if boundp
65 ""
66 "(unbound)"))
67 (<:as-html
68 (if boundp
69 (slot-value object slot-name) "")))))
70
71;;;; ** The default displays for objects with a MEWA occurence
72
73(defdisplay (description object)
74 (<:div
a4e6154d
DC
75 :class "lol-display"
76 (when (label description)
77 (<:span
78 :class "title"
79 (<:as-html (label description))))
2b0fd9c8
DC
80 (do-attributes (attribute description)
81 (<:div
a4e6154d 82 :class "attribute"
2b0fd9c8 83 (display-attribute attribute object)))))
60a24293 84
14a7e1bc 85;;;; ** One line
2b0fd9c8 86(defdisplay
e1645f63 87 :in-layer one-line (description object)
88 "The one line presentation just displays the attributes with a #\Space between them"
89 (do-attributes (attribute description)
90 (display-attribute attribute object)
91 (<:as-html " ")))
14a7e1bc
DC
92
93;;;; ** as-table
94
2b0fd9c8
DC
95(defdisplay :in-layer as-table (description object)
96 (<:table
97 (do-attributes (a description)
14a7e1bc 98 (<:tr
2b0fd9c8
DC
99 (<:td :class "lol-label" (<:as-html (label a)))
100 (<:td (display-attribute a object))))))
14a7e1bc
DC
101
102;;;; List Displays
e1645f63 103
104(deflayer list-display-layer)
105
106(define-layered-class description
107 :in-layer list-display-layer ()
108 ((list-item :initarg :list-item :initform nil :special t :accessor list-item)))
109
2b0fd9c8 110(defdisplay (desc (list list))
e1645f63 111 (with-active-layers (list-display-layer)
e1645f63 112 (<:ul
113 (dolist* (item list)
114 (<:li (apply #'display* item (list-item desc)))))))
dee565d0 115
14a7e1bc 116;;;; Attributes
2b0fd9c8
DC
117(defdisplay
118 :in-layer editor
119 ((attribute standard-attribute) object)
91b9f259 120 (call-next-method))
dee565d0 121
14a7e1bc 122(define-layered-method display-using-description
2b0fd9c8
DC
123 ((attribute standard-attribute) object component)
124 (with-component (component)
125 (<ucw:a :action (call 'info-message :message (strcat (symbol-package (description.type attribute))":/::" (description.type attribute)))
126 (<:as-html "*" )))
87e47dd6
DC
127 (<:as-html (attribute-value object attribute)))
128
dee565d0 129
14a7e1bc 130
dee565d0 131
dee565d0 132
dee565d0
DC
133
134
135
136
137
138