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