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)
45 (display ,object
,@args
))))))
47 (defmethod find-plist (object)
50 (defmethod find-plist ((attribute standard-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 (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
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))
174 (defdisplay (:in-layer as-table
)
176 (do-attributes (a occurence
(attributes))
178 (<:td
(<:as-html
(a-getp :label
)))
179 (<:td
(display-using-description a component object
(a-properties)))))))
184 :description
(desc t
))
187 (<:li
(apply #'display component item properties
)))))
192 (defdisplay (:in-layer
194 :description
(attribute standard-attribute
))
195 "Legacy editor using UCW presentations"
196 (let ((p (lol:make-view object
:type
:editor
)))
197 (present-slot-view p
(getf (find-plist attribute
) :slot-name
))))
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
))))
206 (button (eql 'standard-form-buttons
))
207 :description
(description t
))
208 (<ucw
:submit
:action
(ok component
)
212 (defdisplay (:in-layer wrap-form
213 :combination
:around
)
215 :action
(refresh-component component
)
217 (display component
'standard-form-buttons
)))
220 (defclass/meta test-class
()
221 ((test-string :initform
"test string" :type string
))
222 (:documentation
"foo"))
224 (define-attributes (test-class)
225 (test-string t
:label
"String :" :editablep t
))
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
))))
232 (defmethod render ((self test-component
))
233 (let ((test (instance self
)))
234 (<:h1
(<:as-html
"Lisp on Lines Test Component"))
235 (with-component (self)
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")
243 (<:legend
(<:as-html
(current-type self
)))
244 (display test
:type
(current-type self
)))))
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
))))))
256 (defcomponent standard-display-component
()
257 ((display-function :accessor display-function
:initarg
:display
)))
259 (defmethod render ((self standard-display-component
))
260 (funcall (display-function self
) self
))