filled in the as-table displays. step by step.
[clinton/lisp-on-lines.git] / src / standard-display.lisp
CommitLineData
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
14a7e1bc 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
14a7e1bc 120 ((component t) (object t) &rest args &key (layers '(+ 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