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