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) | |
44 | (<:as-html ,object) | |
45 | (display ,object ,@args)))))) | |
46 | ||
dee565d0 DC |
47 | (defmethod find-plist (object) |
48 | (list)) | |
14a7e1bc | 49 | ` |
dee565d0 DC |
50 | (defmethod find-plist ((attribute standard-attribute)) |
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)))) | |
155 | (warn "trying to render ~A in ~A" attribute object) | |
156 | (with-plist ((plist-union (rest att) (find-plist attribute))) | |
157 | (<:p :class "attribute" | |
158 | (<:span :class "label" (<:as-html (getp :label) " ")) | |
159 | (display-using-description | |
160 | attribute | |
161 | component | |
162 | object | |
163 | (rest att)))))))) | |
164 | ||
14a7e1bc DC |
165 | ;;;; ** One line |
166 | (defdisplay (:in-layer one-line) | |
167 | (do-attributes (attribute occurence (or (getp :attributes) | |
168 | (list-slots object))) | |
169 | (display-using-description attribute component object (attribute-properties)) | |
170 | (<:as-html " "))) | |
171 | ||
172 | ;;;; ** as-table | |
173 | ||
174 | (defdisplay (:in-layer as-table) | |
175 | (<:table | |
176 | (do-attributes (a occurence (attributes)) | |
177 | (<:tr | |
178 | (<:td (<:as-html (a-getp :label))) | |
179 | (<:td (display-using-description a component object (a-properties))))))) | |
180 | ||
181 | ;;;; List Displays | |
182 | (defdisplay (:class | |
183 | (list list) | |
184 | :description (desc t)) | |
185 | (<:ul | |
186 | (dolist* (item list) | |
187 | (<:li (apply #'display component item properties))))) | |
dee565d0 DC |
188 | |
189 | ||
dee565d0 | 190 | |
14a7e1bc | 191 | ;;;; Attributes |
dee565d0 DC |
192 | (defdisplay (:in-layer |
193 | editor | |
194 | :description (attribute standard-attribute)) | |
14a7e1bc | 195 | "Legacy editor using UCW presentations" |
dee565d0 DC |
196 | (let ((p (lol:make-view object :type :editor))) |
197 | (present-slot-view p (getf (find-plist attribute) :slot-name)))) | |
198 | ||
14a7e1bc DC |
199 | (define-layered-method display-using-description |
200 | ((attribute standard-attribute) component object properties) | |
201 | (let ((p (lol:make-view object :type 'mewa-viewer)) | |
202 | (name (attribute.name attribute))) | |
203 | (when name (present-slot-view p name)))) | |
dee565d0 DC |
204 | |
205 | (defdisplay (:class | |
206 | (button (eql 'standard-form-buttons)) | |
207 | :description (description t)) | |
14a7e1bc DC |
208 | (<ucw:submit :action (ok component) |
209 | :value "Ok.")) | |
dee565d0 DC |
210 | |
211 | ||
212 | (defdisplay (:in-layer wrap-form | |
213 | :combination :around) | |
214 | (<ucw:form | |
215 | :action (refresh-component component) | |
216 | (call-next-method) | |
14a7e1bc DC |
217 | (display component 'standard-form-buttons))) |
218 | ||
dee565d0 DC |
219 | |
220 | (defclass/meta test-class () | |
221 | ((test-string :initform "test string" :type string)) | |
222 | (:documentation "foo")) | |
223 | ||
224 | (define-attributes (test-class) | |
225 | (test-string t :label "String :" :editablep t)) | |
226 | ||
227 | (defcomponent test-component () | |
228 | ((display-types :accessor display-types :initform (list 'viewer 'editor 'creator 'one-line 'as-string)) | |
229 | (current-type :accessor current-type :initform 'viewer) | |
230 | (instance :accessor instance :initform (make-instance 'test-class)))) | |
231 | ||
232 | (defmethod render ((self test-component)) | |
233 | (let ((test (instance self))) | |
234 | (<:h1 (<:as-html "Lisp on Lines Test Component")) | |
235 | (with-component (self) | |
236 | (<ucw:form | |
237 | :action (refresh-component self) | |
238 | (<ucw:select :accessor (current-type self) | |
239 | (dolist* (type (display-types self)) | |
240 | (<ucw:option :value type (<:as-html type)))) | |
241 | (<:input :type "Submit" :value "update") | |
242 | (<:fieldset | |
243 | (<:legend (<:as-html (current-type self))) | |
244 | (display test :type (current-type self))))) | |
245 | ||
246 | (<:div | |
247 | (<:h2 | |
248 | (<:as-html "UCW Presentation based displays (the old school")) | |
249 | (dolist (type '(:viewer :editor :creator :one-line :as-string)) | |
250 | (<:h3 (<:as-html type)) | |
251 | (present-view (test type self)) | |
252 | (<ucw:a :action (call-view (test type self)) | |
253 | (<:as-html "Call to " type)))))) | |
254 | ||
255 | ||
256 | (defcomponent standard-display-component () | |
257 | ((display-function :accessor display-function :initarg :display))) | |
258 | ||
259 | (defmethod render ((self standard-display-component)) | |
260 | (funcall (display-function self) self)) | |
261 | ||
262 | ||
263 | ||
264 | ||
265 | ||
266 |