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 DC |
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 | ||
2b0fd9c8 | 14 | (deflayer creator) |
dee565d0 | 15 | (deflayer one-line) |
14a7e1bc | 16 | (deflayer as-table) |
a4e6154d DC |
17 | |
18 | ||
19 | ||
2b0fd9c8 | 20 | (deflayer as-string) |
14a7e1bc | 21 | |
2b0fd9c8 DC |
22 | (defdisplay |
23 | :in-layer as-string (d o) | |
a4e6154d DC |
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 " ")))) | |
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) | |
49 | (object :accessor object :initarg :object) | |
50 | (args :accessor args :initarg :args))) | |
dee565d0 | 51 | |
2b0fd9c8 DC |
52 | (defmethod render ((self standard-display-component)) |
53 | ||
54 | (apply #'display self (object 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 DC |
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 " "))) | |
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 | |
2b0fd9c8 | 128 | (defdisplay (desc (list list)) |
14a7e1bc DC |
129 | (<:ul |
130 | (dolist* (item list) | |
2b0fd9c8 DC |
131 | (<:li (display* item) |
132 | (<:as-html item))))) | |
dee565d0 | 133 | |
14a7e1bc | 134 | ;;;; Attributes |
2b0fd9c8 DC |
135 | (defdisplay |
136 | :in-layer editor | |
137 | ((attribute standard-attribute) object) | |
14a7e1bc | 138 | "Legacy editor using UCW presentations" |
2b0fd9c8 DC |
139 | |
140 | (warn "USING LEGACY EDITOR FOR ~A" (slot-name attribute))) | |
dee565d0 | 141 | |
14a7e1bc | 142 | (define-layered-method display-using-description |
2b0fd9c8 DC |
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 "*" ))) | |
87e47dd6 DC |
147 | (<:as-html (attribute-value object attribute))) |
148 | ||
dee565d0 | 149 | |
14a7e1bc | 150 | |
dee565d0 | 151 | |
dee565d0 | 152 | |
dee565d0 DC |
153 | |
154 | ||
155 | ||
156 | ||
157 | ||
158 |