Commit | Line | Data |
---|---|---|
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. |
fb04c0a8 | 13 | This allows us to dispatch to a subclasses editor. |
14 | " | |
e1645f63 | 15 | (with-inactive-layers (viewer) |
16 | (call-next-method))) | |
a4e6154d | 17 | |
e1645f63 | 18 | ;;;; These layers affect the layout of the object |
dee565d0 | 19 | (deflayer one-line) |
14a7e1bc | 20 | (deflayer as-table) |
2b0fd9c8 | 21 | (deflayer as-string) |
14a7e1bc | 22 | |
2b0fd9c8 DC |
23 | (defdisplay |
24 | :in-layer as-string (d o) | |
e1645f63 | 25 | (with-inactive-layers (editor viewer one-line as-table show-attribute-labels) |
a4e6154d DC |
26 | (do-attributes (a d) |
27 | (display-attribute a o) | |
28 | (<:as-is " ")))) | |
dee565d0 | 29 | |
2b0fd9c8 DC |
30 | (defmethod list-slots (thing) |
31 | (list 'identity)) | |
d1b0ed7c | 32 | |
87e47dd6 DC |
33 | ;;;; * Object displays. |
34 | ||
a4e6154d | 35 | |
dee565d0 | 36 | |
2b0fd9c8 | 37 | ;;;; TODO: all lisp types should have occurences and attributes defined for them. |
dee565d0 | 38 | |
2b0fd9c8 DC |
39 | (defdisplay ((description t) lisp-value) |
40 | (<:as-html lisp-value)) | |
14a7e1bc | 41 | |
2b0fd9c8 | 42 | (defdisplay (description (object string)) |
dee565d0 DC |
43 | (<:as-html object)) |
44 | ||
ff1e971a | 45 | (defdisplay (description (object symbol)) |
46 | (<:as-html object)) | |
47 | ||
2b0fd9c8 DC |
48 | (defdisplay (description object (component t)) |
49 | "The default display for CLOS objects" | |
50 | (print (class-name (class-of object))) | |
51 | (dolist* (slot-name (list-slots object)) | |
52 | ||
53 | (let ((boundp (slot-boundp object slot-name))) | |
54 | (format t "~A~A : ~A" (strcat slot-name) | |
55 | (if boundp | |
56 | "" | |
57 | "(unbound)") | |
58 | (if boundp | |
59 | (slot-value object slot-name) ""))))) | |
60 | ||
61 | (defdisplay ((description t) object) | |
62 | "The default display for CLOS objects in UCW components" | |
63 | (dolist* (slot-name (list-slots object)) | |
64 | ||
65 | (let ((boundp (slot-boundp object slot-name))) | |
66 | (<:label :class "lol-label" | |
67 | (display-attribute 'label (strcat slot-name)) | |
68 | (if boundp | |
69 | "" | |
70 | "(unbound)")) | |
71 | (<:as-html | |
72 | (if boundp | |
73 | (slot-value object slot-name) ""))))) | |
74 | ||
75 | ;;;; ** The default displays for objects with a MEWA occurence | |
76 | ||
77 | (defdisplay (description object) | |
78 | (<:div | |
a4e6154d DC |
79 | :class "lol-display" |
80 | (when (label description) | |
81 | (<:span | |
82 | :class "title" | |
83 | (<:as-html (label description)))) | |
2b0fd9c8 DC |
84 | (do-attributes (attribute description) |
85 | (<:div | |
a4e6154d | 86 | :class "attribute" |
2b0fd9c8 | 87 | (display-attribute attribute object))))) |
60a24293 | 88 | |
14a7e1bc | 89 | ;;;; ** One line |
2b0fd9c8 | 90 | (defdisplay |
e1645f63 | 91 | :in-layer one-line (description object) |
92 | "The one line presentation just displays the attributes with a #\Space between them" | |
93 | (do-attributes (attribute description) | |
94 | (display-attribute attribute object) | |
95 | (<:as-html " "))) | |
14a7e1bc DC |
96 | |
97 | ;;;; ** as-table | |
98 | ||
2b0fd9c8 DC |
99 | (defdisplay :in-layer as-table (description object) |
100 | (<:table | |
101 | (do-attributes (a description) | |
14a7e1bc | 102 | (<:tr |
2b0fd9c8 DC |
103 | (<:td :class "lol-label" (<:as-html (label a))) |
104 | (<:td (display-attribute a object)))))) | |
14a7e1bc DC |
105 | |
106 | ;;;; List Displays | |
e1645f63 | 107 | |
108 | (deflayer list-display-layer) | |
109 | ||
110 | (define-layered-class description | |
111 | :in-layer list-display-layer () | |
fb04c0a8 | 112 | ((list-item :initarg :list-item |
113 | :initarg :table-item | |
114 | :initform nil | |
115 | :special t | |
116 | :accessor list-item))) | |
e1645f63 | 117 | |
2b0fd9c8 | 118 | (defdisplay (desc (list list)) |
e1645f63 | 119 | (with-active-layers (list-display-layer) |
e1645f63 | 120 | (<:ul |
121 | (dolist* (item list) | |
122 | (<:li (apply #'display* item (list-item desc))))))) | |
dee565d0 | 123 | |
fb04c0a8 | 124 | (defdisplay :in-layer as-table (description (list list)) |
125 | (with-active-layers (list-display-layer) | |
126 | (let ((item-description (find-occurence (first list)))) | |
127 | (<:table | |
128 | (funcall | |
129 | (apply #'lol::make-display-function self (first list) | |
130 | (list-item description)) | |
131 | (lambda (desc item component) | |
132 | (<:tr | |
133 | (do-attributes (a desc) | |
134 | (<:th (<:as-html (label a))))) | |
135 | ||
136 | (dolist* (obj list) | |
137 | (<:tr | |
138 | (do-attributes (a desc) | |
139 | (<:td (display-attribute a obj))))))))))) | |
140 | ||
14a7e1bc | 141 | ;;;; Attributes |
2b0fd9c8 DC |
142 | (defdisplay |
143 | :in-layer editor | |
144 | ((attribute standard-attribute) object) | |
91b9f259 | 145 | (call-next-method)) |
dee565d0 | 146 | |
14a7e1bc | 147 | (define-layered-method display-using-description |
2b0fd9c8 DC |
148 | ((attribute standard-attribute) object component) |
149 | (with-component (component) | |
150 | (<ucw:a :action (call 'info-message :message (strcat (symbol-package (description.type attribute))":/::" (description.type attribute))) | |
151 | (<:as-html "*" ))) | |
87e47dd6 DC |
152 | (<:as-html (attribute-value object attribute))) |
153 | ||
dee565d0 | 154 | |
14a7e1bc | 155 | |
dee565d0 | 156 | |
dee565d0 | 157 | |
dee565d0 DC |
158 | |
159 | ||
160 | ||
161 | ||
162 | ||
163 |