Export LoL 3 symbols
[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
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