1 (in-package :lisp-on-lines
)
4 ;;;; The Standard Layer Hierarchy
6 (deflayer editor
(viewer))
7 (deflayer creator
(editor))
16 (define-attributes (contextl-default)
22 (defmacro with-component
((component) &body body
)
23 `(let ((self ,component
))
24 (flet ((display* (thing &rest args
)
25 (apply #'display
,component thing args
)))
29 (define-layered-function find-display-type
(object))
31 (define-layered-method find-display-type
(object)
34 (define-layered-function find-display-layers
(object))
36 (define-layered-method find-display-layers
(object)
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
))))))
46 (defmethod find-plist (object)
49 (defmethod find-plist ((attribute standard-attribute
))
50 (warn "atttributre plist ~A" (attribute.plist attribute
))
51 (attribute.plist attribute
))
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
))
65 (declare (ignorable #',get
#',set
#',props
))
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
))
75 (,type
(getf ,plist
: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
)
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
))
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
)
98 (with-plist ((plist-union properties
(find-plist ,(car description
))))
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
))
111 (define-layered-function display
(component object
&rest args
)
113 "Displays OBJECT in COMPONENT.
115 default action is to FUNCALL-WITH-LAYERS the DISPLAY-USING-DESCRIPTION method."))
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
)
125 (getf plist
:layers
))))
128 #'display-using-description occurence component object
(plist-union args plist
))))
131 (define-layered-method display
132 ((component t
) (object t
) &rest args
&key layers
(type 'viewer
) &allow-other-keys
)
135 #'display-using-description t component object args
))
138 (define-layered-function display-using-description
(description component object properties
)
140 "Render the object in component, using DESCRIPTION, which is an occurence, and attribute, or something else"))
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
))
147 ;;;; * Object Presentations
148 (define-layered-method display-using-description
149 ((occurence standard-occurence
) component object properties
)
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
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))
177 (defdisplay (:in-layer as-table
)
179 (do-attributes (a occurence
(attributes))
181 (<:td
(<:as-html
(a-getp :label
)))
182 (<:td
(display-using-description a component object
(a-properties)))))))
187 :description
(desc t
))
190 (<:li
(apply #'display component item properties
)))))
195 (defdisplay (:in-layer
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
))))
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
))))
209 (button (eql 'standard-form-buttons
))
210 :description
(description t
))
211 (<ucw
:submit
:action
(ok component
)
214 (defdisplay (:in-layer wrap-form
215 :combination
:around
)
217 :action
(refresh-component component
)
219 (display component
'standard-form-buttons
)))
222 (defclass/meta test-class
()
223 ((test-string :initform
"test string" :type string
))
224 (:documentation
"foo"))
226 (define-attributes (test-class)
227 (test-string t
:label
"String :" :editablep t
))
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
))))
234 (defmethod render ((self test-component
))
235 (let ((test (instance self
)))
236 (<:h1
(<:as-html
"Lisp on Lines Test Component"))
237 (with-component (self)
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")
245 (<:legend
(<:as-html
(current-type self
)))
246 (display test
:type
(current-type self
)))))
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
))))))
258 (defcomponent standard-display-component
()
259 ((display-function :accessor display-function
:initarg
:display
)))
261 (defmethod render ((self standard-display-component
))
262 (funcall (display-function self
) self
))