add support for lines to default display
[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
d1b0ed7c 32
2b0fd9c8 33;;;; TODO : this doesn't work
d1b0ed7c 34
2b0fd9c8
DC
35(defaction call-display-with-context ((from component) object context &rest properties)
36 (call-component self (make-instance 'standard-display-component
37 :context context
38 :object object
39 :args (if (cdr properties)
40 properties
41 (car properties)))))
d1b0ed7c 42
2b0fd9c8
DC
43(defmacro call-display (component object &rest properties)
44 `(let ()
45 (call-display-with-context ,component ,object nil ,@properties)))
d1b0ed7c 46
2b0fd9c8
DC
47(defcomponent standard-display-component ()
48 ((context :accessor context :initarg :context)
e1645f63 49 (object :accessor object-of :initarg :object)
2b0fd9c8 50 (args :accessor args :initarg :args)))
dee565d0 51
2b0fd9c8
DC
52(defmethod render ((self standard-display-component))
53
e1645f63 54 (apply #'display self (object-of self) (args self)))
dee565d0 55
87e47dd6
DC
56
57;;;; * Object displays.
58
a4e6154d 59
dee565d0 60
2b0fd9c8 61;;;; TODO: all lisp types should have occurences and attributes defined for them.
dee565d0 62
2b0fd9c8
DC
63(defdisplay ((description t) lisp-value)
64 (<:as-html lisp-value))
14a7e1bc 65
2b0fd9c8 66(defdisplay (description (object string))
dee565d0
DC
67 (<:as-html object))
68
2b0fd9c8
DC
69(defdisplay (description object (component t))
70 "The default display for CLOS objects"
71 (print (class-name (class-of object)))
72 (dolist* (slot-name (list-slots object))
73
74 (let ((boundp (slot-boundp object slot-name)))
75 (format t "~A~A : ~A" (strcat slot-name)
76 (if boundp
77 ""
78 "(unbound)")
79 (if boundp
80 (slot-value object slot-name) "")))))
81
82(defdisplay ((description t) object)
83 "The default display for CLOS objects in UCW components"
84 (dolist* (slot-name (list-slots object))
85
86 (let ((boundp (slot-boundp object slot-name)))
87 (<:label :class "lol-label"
88 (display-attribute 'label (strcat slot-name))
89 (if boundp
90 ""
91 "(unbound)"))
92 (<:as-html
93 (if boundp
94 (slot-value object slot-name) "")))))
95
96;;;; ** The default displays for objects with a MEWA occurence
97
98(defdisplay (description object)
99 (<:div
a4e6154d
DC
100 :class "lol-display"
101 (when (label description)
102 (<:span
103 :class "title"
104 (<:as-html (label description))))
2b0fd9c8
DC
105 (do-attributes (attribute description)
106 (<:div
a4e6154d 107 :class "attribute"
2b0fd9c8 108 (display-attribute attribute object)))))
60a24293 109
14a7e1bc 110;;;; ** One line
2b0fd9c8 111(defdisplay
e1645f63 112 :in-layer one-line (description object)
113 "The one line presentation just displays the attributes with a #\Space between them"
114 (do-attributes (attribute description)
115 (display-attribute attribute object)
116 (<:as-html " ")))
14a7e1bc
DC
117
118;;;; ** as-table
119
2b0fd9c8
DC
120(defdisplay :in-layer as-table (description object)
121 (<:table
122 (do-attributes (a description)
14a7e1bc 123 (<:tr
2b0fd9c8
DC
124 (<:td :class "lol-label" (<:as-html (label a)))
125 (<:td (display-attribute a object))))))
14a7e1bc
DC
126
127;;;; List Displays
e1645f63 128
129(deflayer list-display-layer)
130
131(define-layered-class description
132 :in-layer list-display-layer ()
133 ((list-item :initarg :list-item :initform nil :special t :accessor list-item)))
134
2b0fd9c8 135(defdisplay (desc (list list))
e1645f63 136 (with-active-layers (list-display-layer)
137
138 (<:ul
139 (dolist* (item list)
140 (<:li (apply #'display* item (list-item desc)))))))
dee565d0 141
14a7e1bc 142;;;; Attributes
2b0fd9c8
DC
143(defdisplay
144 :in-layer editor
145 ((attribute standard-attribute) object)
14a7e1bc 146 "Legacy editor using UCW presentations"
2b0fd9c8
DC
147
148 (warn "USING LEGACY EDITOR FOR ~A" (slot-name attribute)))
dee565d0 149
14a7e1bc 150(define-layered-method display-using-description
2b0fd9c8
DC
151 ((attribute standard-attribute) object component)
152 (with-component (component)
153 (<ucw:a :action (call 'info-message :message (strcat (symbol-package (description.type attribute))":/::" (description.type attribute)))
154 (<:as-html "*" )))
87e47dd6
DC
155 (<:as-html (attribute-value object attribute)))
156
dee565d0 157
14a7e1bc 158
dee565d0 159
dee565d0 160
dee565d0
DC
161
162
163
164
165
166