added the image attribute and a naive image picker
[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
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
42 :display #'(lambda (component)
43 (with-component (component)
44 (display ,component ,object ,@args))))))
45
46 (defmethod find-plist (object)
47 (list))
48
49 (defmethod find-plist ((attribute standard-attribute))
50 (warn "atttributre plist ~A" (attribute.plist 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"))))
56 (set (intern (string-upcase (if prefix (strcat prefix '-setp) "SETP"))))
57 (props (intern (string-upcase (if prefix (strcat prefix '-properties) "PROPERTIES")))))
58 `(let ((,p ,plist-form))
59 (flet ((,get (p)
60 (getf ,p p))
61 (,set (p v)
62 (setf (getf ,p p) v))
63 (,props ()
64 ,p))
65 (declare (ignorable #',get #',set #',props))
66 ,@body)))))
67
68
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
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)
90 (let ((class-spec (if object (if (listp object) object (list object object)) 'object)))
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
95 ,class-spec properties)
96
97
98 (with-plist ((plist-union properties (find-plist ,(car description))))
99
100 ,(if (not description-supplied-p)
101 `(flet ((attributes ()
102 (or (getp :attributes)
103 (list-slots ,(car (ensure-list class-spec))))))
104 (declare (ignorable #'attributes))
105
106 ,@body)
107 `(progn ,@body)))) )
108 )
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
117 (define-layered-method display
118 ((component t) (object standard-object) &rest args &key layers (type 'viewer) &allow-other-keys)
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
130
131 (define-layered-method display
132 ((component t) (object t) &rest args &key layers (type 'viewer) &allow-other-keys)
133 (funcall-with-layers
134 layers
135 #'display-using-description t component object args))
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
147 ;;;; * Object Presentations
148 (define-layered-method display-using-description
149 ((occurence standard-occurence) component object properties)
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 (with-plist ((plist-union (rest att) (find-plist attribute)))
156 (<:p :class "attribute"
157 (and (getp :show-labels-p) (<:span :class "label" (<:as-html (or (getp :label) "") " ")))
158 (display-using-description
159 attribute
160 component
161 object
162 (rest att))))))))
163
164
165
166
167 ;;;; ** One line
168 (defdisplay (:in-layer one-line)
169 "The one line presentation just displays the attributes with a #\Space between them"
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)))))
191
192
193
194 ;;;; Attributes
195 (defdisplay (:in-layer
196 editor
197 :description (attribute standard-attribute))
198 "Legacy editor using UCW presentations"
199 (let ((p (lol:make-view object :type :editor)))
200 (present-slot-view p (getf (find-plist attribute) :slot-name))))
201
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))))
207
208 (defdisplay (:class
209 (button (eql 'standard-form-buttons))
210 :description (description t))
211 (<ucw:submit :action (ok component)
212 :value "Ok."))
213
214 (defdisplay (:in-layer wrap-form
215 :combination :around)
216 (<ucw:form
217 :action (refresh-component component)
218 (call-next-method)
219 (display component 'standard-form-buttons)))
220
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