Commit | Line | Data |
---|---|---|
dee565d0 DC |
1 | (in-package :lisp-on-lines) |
2 | ||
3 | ||
4 | ;;;; The Standard Layer Hierarchy | |
5 | (deflayer viewer) | |
6 | (deflayer editor (viewer)) | |
7 | (deflayer creator (editor)) | |
8 | ||
9 | ;;;; 'Mixin' Layers | |
10 | (deflayer one-line) | |
11 | ||
12 | (deflayer wrap-form) | |
13 | ||
14a7e1bc DC |
14 | (deflayer as-table) |
15 | ||
dee565d0 DC |
16 | (define-attributes (contextl-default) |
17 | (:viewer viewer) | |
18 | (:editor editor) | |
19 | (:creator creator)) | |
20 | ||
21 | ||
22 | (defmacro with-component ((component) &body body) | |
23 | `(let ((self ,component)) | |
24 | (flet ((display* (thing &rest args) | |
25 | (apply #'display ,component thing args))) | |
26 | ,@body))) | |
27 | ||
d1b0ed7c DC |
28 | |
29 | (define-layered-function find-display-type (object)) | |
30 | ||
31 | (define-layered-method find-display-type (object) | |
32 | 'viewer) | |
33 | ||
34 | (define-layered-function find-display-layers (object)) | |
35 | ||
36 | (define-layered-method find-display-layers (object) | |
37 | "layered function" | |
38 | nil) | |
39 | ||
40 | (defmacro call-display (component object &rest args) | |
41 | `(call-component ,component (make-instance 'standard-display-component | |
dee565d0 DC |
42 | :display #'(lambda (component) |
43 | (with-component (component) | |
60a24293 | 44 | (display ,component ,object ,@args)))))) |
dee565d0 | 45 | |
dee565d0 DC |
46 | (defmethod find-plist (object) |
47 | (list)) | |
60a24293 | 48 | |
dee565d0 | 49 | (defmethod find-plist ((attribute standard-attribute)) |
60a24293 | 50 | (warn "atttributre plist ~A" (attribute.plist attribute)) |
dee565d0 DC |
51 | (attribute.plist attribute)) |
52 | ||
53 | (defmacro with-plist ((plist-form &optional prefix) &body body) | |
54 | (with-unique-names (p) | |
55 | (let ((get (intern (string-upcase (if prefix (strcat prefix '-getp) "GETP")))) | |
14a7e1bc DC |
56 | (set (intern (string-upcase (if prefix (strcat prefix '-setp) "SETP")))) |
57 | (props (intern (string-upcase (if prefix (strcat prefix '-properties) "PROPERTIES"))))) | |
dee565d0 DC |
58 | `(let ((,p ,plist-form)) |
59 | (flet ((,get (p) | |
60 | (getf ,p p)) | |
61 | (,set (p v) | |
14a7e1bc DC |
62 | (setf (getf ,p p) v)) |
63 | (,props () | |
64 | ,p)) | |
65 | (declare (ignorable #',get #',set #',props)) | |
dee565d0 DC |
66 | ,@body))))) |
67 | ||
68 | ||
14a7e1bc DC |
69 | ;;;;; Macros |
70 | (defmacro do-attributes ((var occurence attributes) &body body) | |
71 | (with-unique-names (att plist type) | |
72 | `(loop for ,att in ,attributes | |
73 | do (let* ((,att (ensure-list ,att)) | |
74 | (,plist (rest ,att)) | |
75 | (,type (getf ,plist :type)) | |
76 | (,var (if ,type | |
77 | (make-attribute :name (first ,att) :type ,type :plist ,plist) | |
78 | (find-attribute ,occurence (first ,att))))) | |
79 | (with-plist ((plist-union (rest ,att) (find-plist ,var)) ,var) | |
80 | ,@body))))) | |
81 | ||
82 | ||
dee565d0 DC |
83 | (defmacro defdisplay ((&key |
84 | (in-layer nil layer-supplied-p) | |
85 | (combination nil combination-supplied-p) | |
86 | (description '(occurence standard-occurence) description-supplied-p) | |
87 | (component 'component) | |
88 | ((:class object) nil)) | |
89 | &body body) | |
14a7e1bc | 90 | (let ((class-spec (if object (if (listp object) object (list object object)) 'object))) |
dee565d0 DC |
91 | `(define-layered-method display-using-description |
92 | ,@(when layer-supplied-p `(:in-layer ,in-layer)) | |
93 | ,@(when combination-supplied-p `(,combination)) | |
94 | (,description ,component | |
14a7e1bc DC |
95 | ,class-spec properties) |
96 | ||
dee565d0 DC |
97 | |
98 | (with-plist ((plist-union properties (find-plist ,(car description)))) | |
99 | ||
100 | ,(if (not description-supplied-p) | |
14a7e1bc DC |
101 | `(flet ((attributes () |
102 | (or (getp :attributes) | |
103 | (list-slots ,(car (ensure-list class-spec)))))) | |
104 | (declare (ignorable #'attributes)) | |
dee565d0 DC |
105 | |
106 | ,@body) | |
14a7e1bc DC |
107 | `(progn ,@body)))) ) |
108 | ) | |
dee565d0 DC |
109 | |
110 | ||
111 | (define-layered-function display (component object &rest args) | |
112 | (:documentation | |
113 | "Displays OBJECT in COMPONENT. | |
114 | ||
115 | default action is to FUNCALL-WITH-LAYERS the DISPLAY-USING-DESCRIPTION method.")) | |
116 | ||
dee565d0 | 117 | (define-layered-method display |
a9e8666b | 118 | ((component t) (object standard-object) &rest args &key layers (type 'viewer) &allow-other-keys) |
dee565d0 DC |
119 | (let* ((occurence (find-occurence object)) |
120 | (plist (attribute.plist | |
121 | (find-attribute occurence (intern (format nil "~A" type) :KEYWORD)))) | |
122 | (layers (append (when type (loop for ty in (ensure-list type) | |
123 | nconc `(+ ,ty))) | |
124 | layers | |
125 | (getf plist :layers)))) | |
126 | (funcall-with-layers | |
127 | layers | |
128 | #'display-using-description occurence component object (plist-union args plist)))) | |
129 | ||
14a7e1bc | 130 | |
dee565d0 | 131 | (define-layered-method display |
d2882889 | 132 | ((component t) (object t) &rest args &key layers (type 'viewer) &allow-other-keys) |
dee565d0 | 133 | (funcall-with-layers |
14a7e1bc DC |
134 | layers |
135 | #'display-using-description t component object args)) | |
dee565d0 DC |
136 | |
137 | ||
138 | (define-layered-function display-using-description (description component object properties) | |
139 | (:documentation | |
140 | "Render the object in component, using DESCRIPTION, which is an occurence, and attribute, or something else")) | |
141 | ||
142 | (define-layered-method display-using-description (description component object properties) | |
143 | "The standard display simply prints the object" | |
144 | (declare (ignore component properties description)) | |
145 | (<:as-html object)) | |
146 | ||
14a7e1bc | 147 | ;;;; * Object Presentations |
dee565d0 | 148 | (define-layered-method display-using-description |
14a7e1bc | 149 | ((occurence standard-occurence) component object properties) |
dee565d0 DC |
150 | |
151 | (with-plist (properties o) | |
152 | (loop for att in (or (o-getp :attributes) (list-slots object)) | |
153 | do (let* ((att (ensure-list att)) | |
154 | (attribute (find-attribute occurence (first att)))) | |
dee565d0 DC |
155 | (with-plist ((plist-union (rest att) (find-plist attribute))) |
156 | (<:p :class "attribute" | |
60a24293 | 157 | (and (getp :show-labels-p) (<:span :class "label" (<:as-html (or (getp :label) "") " "))) |
dee565d0 DC |
158 | (display-using-description |
159 | attribute | |
160 | component | |
161 | object | |
162 | (rest att)))))))) | |
163 | ||
60a24293 DC |
164 | |
165 | ||
166 | ||
14a7e1bc DC |
167 | ;;;; ** One line |
168 | (defdisplay (:in-layer one-line) | |
60a24293 | 169 | "The one line presentation just displays the attributes with a #\Space between them" |
14a7e1bc DC |
170 | (do-attributes (attribute occurence (or (getp :attributes) |
171 | (list-slots object))) | |
172 | (display-using-description attribute component object (attribute-properties)) | |
173 | (<:as-html " "))) | |
174 | ||
175 | ;;;; ** as-table | |
176 | ||
177 | (defdisplay (:in-layer as-table) | |
178 | (<:table | |
179 | (do-attributes (a occurence (attributes)) | |
180 | (<:tr | |
181 | (<:td (<:as-html (a-getp :label))) | |
182 | (<:td (display-using-description a component object (a-properties))))))) | |
183 | ||
184 | ;;;; List Displays | |
185 | (defdisplay (:class | |
186 | (list list) | |
187 | :description (desc t)) | |
188 | (<:ul | |
189 | (dolist* (item list) | |
190 | (<:li (apply #'display component item properties))))) | |
dee565d0 DC |
191 | |
192 | ||
dee565d0 | 193 | |
14a7e1bc | 194 | ;;;; Attributes |
dee565d0 DC |
195 | (defdisplay (:in-layer |
196 | editor | |
197 | :description (attribute standard-attribute)) | |
14a7e1bc | 198 | "Legacy editor using UCW presentations" |
dee565d0 DC |
199 | (let ((p (lol:make-view object :type :editor))) |
200 | (present-slot-view p (getf (find-plist attribute) :slot-name)))) | |
201 | ||
14a7e1bc DC |
202 | (define-layered-method display-using-description |
203 | ((attribute standard-attribute) component object properties) | |
204 | (let ((p (lol:make-view object :type 'mewa-viewer)) | |
205 | (name (attribute.name attribute))) | |
206 | (when name (present-slot-view p name)))) | |
dee565d0 DC |
207 | |
208 | (defdisplay (:class | |
209 | (button (eql 'standard-form-buttons)) | |
210 | :description (description t)) | |
14a7e1bc DC |
211 | (<ucw:submit :action (ok component) |
212 | :value "Ok.")) | |
dee565d0 | 213 | |
dee565d0 DC |
214 | (defdisplay (:in-layer wrap-form |
215 | :combination :around) | |
216 | (<ucw:form | |
217 | :action (refresh-component component) | |
218 | (call-next-method) | |
14a7e1bc DC |
219 | (display component 'standard-form-buttons))) |
220 | ||
dee565d0 DC |
221 | |
222 | (defclass/meta test-class () | |
223 | ((test-string :initform "test string" :type string)) | |
224 | (:documentation "foo")) | |
225 | ||
226 | (define-attributes (test-class) | |
227 | (test-string t :label "String :" :editablep t)) | |
228 | ||
229 | (defcomponent test-component () | |
230 | ((display-types :accessor display-types :initform (list 'viewer 'editor 'creator 'one-line 'as-string)) | |
231 | (current-type :accessor current-type :initform 'viewer) | |
232 | (instance :accessor instance :initform (make-instance 'test-class)))) | |
233 | ||
234 | (defmethod render ((self test-component)) | |
235 | (let ((test (instance self))) | |
236 | (<:h1 (<:as-html "Lisp on Lines Test Component")) | |
237 | (with-component (self) | |
238 | (<ucw:form | |
239 | :action (refresh-component self) | |
240 | (<ucw:select :accessor (current-type self) | |
241 | (dolist* (type (display-types self)) | |
242 | (<ucw:option :value type (<:as-html type)))) | |
243 | (<:input :type "Submit" :value "update") | |
244 | (<:fieldset | |
245 | (<:legend (<:as-html (current-type self))) | |
246 | (display test :type (current-type self))))) | |
247 | ||
248 | (<:div | |
249 | (<:h2 | |
250 | (<:as-html "UCW Presentation based displays (the old school")) | |
251 | (dolist (type '(:viewer :editor :creator :one-line :as-string)) | |
252 | (<:h3 (<:as-html type)) | |
253 | (present-view (test type self)) | |
254 | (<ucw:a :action (call-view (test type self)) | |
255 | (<:as-html "Call to " type)))))) | |
256 | ||
257 | ||
258 | (defcomponent standard-display-component () | |
259 | ((display-function :accessor display-function :initarg :display))) | |
260 | ||
261 | (defmethod render ((self standard-display-component)) | |
262 | (funcall (display-function self) self)) | |
263 | ||
264 | ||
265 | ||
266 | ||
267 | ||
268 |