filled in the as-table displays. step by step.
[clinton/lisp-on-lines.git] / src / standard-display.lisp
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
14 (deflayer as-table)
15
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
35 (defmethod find-plist (object)
36 (list))
37 `
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"))))
44 (set (intern (string-upcase (if prefix (strcat prefix '-setp) "SETP"))))
45 (props (intern (string-upcase (if prefix (strcat prefix '-properties) "PROPERTIES")))))
46 `(let ((,p ,plist-form))
47 (flet ((,get (p)
48 (getf ,p p))
49 (,set (p v)
50 (setf (getf ,p p) v))
51 (,props ()
52 ,p))
53 (declare (ignorable #',get #',set #',props))
54 ,@body)))))
55
56
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
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)
78 (let ((class-spec (if object (if (listp object) object (list object object)) 'object)))
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
83 ,class-spec properties)
84
85
86 (with-plist ((plist-union properties (find-plist ,(car description))))
87
88 ,(if (not description-supplied-p)
89 `(flet ((attributes ()
90 (or (getp :attributes)
91 (list-slots ,(car (ensure-list class-spec))))))
92 (declare (ignorable #'attributes))
93
94 ,@body)
95 `(progn ,@body)))) )
96 )
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
105 (define-layered-method display
106 ((component t) (object standard-object) &rest args &key layers (type 'viewer) &allow-other-keys)
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
118
119 (define-layered-method display
120 ((component t) (object t) &rest args &key (layers '(+ viewer)) &allow-other-keys)
121 (funcall-with-layers
122 layers
123 #'display-using-description t component object args))
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
135 ;;;; * Object Presentations
136 (define-layered-method display-using-description
137 ((occurence standard-occurence) component object properties)
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
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)))))
176
177
178
179 ;;;; Attributes
180 (defdisplay (:in-layer
181 editor
182 :description (attribute standard-attribute))
183 "Legacy editor using UCW presentations"
184 (let ((p (lol:make-view object :type :editor)))
185 (present-slot-view p (getf (find-plist attribute) :slot-name))))
186
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))))
192
193 (defdisplay (:class
194 (button (eql 'standard-form-buttons))
195 :description (description t))
196 (<ucw:submit :action (ok component)
197 :value "Ok."))
198
199
200 (defdisplay (:in-layer wrap-form
201 :combination :around)
202 (<ucw:form
203 :action (refresh-component component)
204 (call-next-method)
205 (display component 'standard-form-buttons)))
206
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