Removed legacy files from .asd
[clinton/lisp-on-lines.git] / src / standard-display.lisp
1 (in-package :lisp-on-lines)
2
3 ;;;; The Standard Layers
4 (deflayer viewer)
5 (deflayer editor)
6
7 (defdisplay
8 :in-layer editor :around (description object)
9 "It is useful to remove the viewer layer when in the editing layer.
10 This allows us to dispatch to a subclasses editor."
11 (with-inactive-layers (viewer)
12 (call-next-method)))
13
14 (deflayer creator)
15 (deflayer one-line)
16 (deflayer as-table)
17
18
19
20 (deflayer as-string)
21
22 (defdisplay
23 :in-layer as-string (d o)
24 (with-inactive-layers (editor viewer creator one-line as-table label-attributes)
25 (do-attributes (a d)
26 (display-attribute a o)
27 (<:as-is " "))))
28
29 (defmethod list-slots (thing)
30 (list 'identity))
31
32
33 ;;;; TODO : this doesn't work
34
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)))))
42
43 (defmacro call-display (component object &rest properties)
44 `(let ()
45 (call-display-with-context ,component ,object nil ,@properties)))
46
47 (defcomponent standard-display-component ()
48 ((context :accessor context :initarg :context)
49 (object :accessor object :initarg :object)
50 (args :accessor args :initarg :args)))
51
52 (defmethod render ((self standard-display-component))
53
54 (apply #'display self (object self) (args self)))
55
56
57 ;;;; * Object displays.
58
59
60
61 ;;;; TODO: all lisp types should have occurences and attributes defined for them.
62
63 (defdisplay ((description t) lisp-value)
64 (<:as-html lisp-value))
65
66 (defdisplay (description (object string))
67 (<:as-html object))
68
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
100 :class "lol-display"
101 (when (label description)
102 (<:span
103 :class "title"
104 (<:as-html (label description))))
105 (do-attributes (attribute description)
106 (<:div
107 :class "attribute"
108 (display-attribute attribute object)))))
109
110 ;;;; ** One line
111 (defdisplay
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 " ")))
117
118 ;;;; ** as-table
119
120 (defdisplay :in-layer as-table (description object)
121 (<:table
122 (do-attributes (a description)
123 (<:tr
124 (<:td :class "lol-label" (<:as-html (label a)))
125 (<:td (display-attribute a object))))))
126
127 ;;;; List Displays
128 (defdisplay (desc (list list))
129 (<:ul
130 (dolist* (item list)
131 (<:li (display* item)
132 (<:as-html item)))))
133
134 ;;;; Attributes
135 (defdisplay
136 :in-layer editor
137 ((attribute standard-attribute) object)
138 "Legacy editor using UCW presentations"
139
140 (warn "USING LEGACY EDITOR FOR ~A" (slot-name attribute)))
141
142 (define-layered-method display-using-description
143 ((attribute standard-attribute) object component)
144 (with-component (component)
145 (<ucw:a :action (call 'info-message :message (strcat (symbol-package (description.type attribute))":/::" (description.type attribute)))
146 (<:as-html "*" )))
147 (<:as-html (attribute-value object attribute)))
148
149
150
151
152
153
154
155
156
157
158