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
)))
28 (defmacro call-display
(object &rest args
)
29 `(call-component self
(make-instance 'standard-display-component
30 :display
#'(lambda (component)
31 (with-component (component)
33 (display ,object
,@args
))))))
35 (defmethod find-plist (object)
38 (defmethod find-plist ((attribute standard-attribute
))
39 (attribute.plist attribute
))
41 (defmacro with-plist
((plist-form &optional prefix
) &body body
)
42 (with-unique-names (p)
43 (let ((get (intern (string-upcase (if prefix
(strcat prefix
'-getp
) "GETP"))))
44 (set (intern (string-upcase (if prefix
(strcat prefix
'-setp
) "SETP"))))
45 (props (intern (string-upcase (if prefix
(strcat prefix
'-properties
) "PROPERTIES")))))
46 `(let ((,p
,plist-form
))
53 (declare (ignorable #',get
#',set
#',props
))
58 (defmacro do-attributes
((var occurence attributes
) &body body
)
59 (with-unique-names (att plist type
)
60 `(loop for
,att in
,attributes
61 do
(let* ((,att
(ensure-list ,att
))
63 (,type
(getf ,plist
:type
))
65 (make-attribute :name
(first ,att
) :type
,type
:plist
,plist
)
66 (find-attribute ,occurence
(first ,att
)))))
67 (with-plist ((plist-union (rest ,att
) (find-plist ,var
)) ,var
)
71 (defmacro defdisplay
((&key
72 (in-layer nil layer-supplied-p
)
73 (combination nil combination-supplied-p
)
74 (description '(occurence standard-occurence
) description-supplied-p
)
75 (component 'component
)
76 ((:class object
) nil
))
78 (let ((class-spec (if object
(if (listp object
) object
(list object object
)) 'object
)))
79 `(define-layered-method display-using-description
80 ,@(when layer-supplied-p
`(:in-layer
,in-layer
))
81 ,@(when combination-supplied-p
`(,combination
))
82 (,description
,component
83 ,class-spec properties
)
86 (with-plist ((plist-union properties
(find-plist ,(car description
))))
88 ,(if (not description-supplied-p
)
89 `(flet ((attributes ()
90 (or (getp :attributes
)
91 (list-slots ,(car (ensure-list class-spec
))))))
92 (declare (ignorable #'attributes
))
99 (define-layered-function display
(component object
&rest args
)
101 "Displays OBJECT in COMPONENT.
103 default action is to FUNCALL-WITH-LAYERS the DISPLAY-USING-DESCRIPTION method."))
105 (define-layered-method display
106 ((component t
) (object t
) &rest args
&key layers
(type 'viewer
) &allow-other-keys
)
107 (let* ((occurence (find-occurence object
))
108 (plist (attribute.plist
109 (find-attribute occurence
(intern (format nil
"~A" type
) :KEYWORD
))))
110 (layers (append (when type
(loop for ty in
(ensure-list type
)
113 (getf plist
:layers
))))
116 #'display-using-description occurence component object
(plist-union args plist
))))
119 (define-layered-method display
120 ((component t
) (object t
) &rest args
&key layers
(type 'viewer
) &allow-other-keys
)
123 #'display-using-description t component object args
))
126 (define-layered-function display-using-description
(description component object properties
)
128 "Render the object in component, using DESCRIPTION, which is an occurence, and attribute, or something else"))
130 (define-layered-method display-using-description
(description component object properties
)
131 "The standard display simply prints the object"
132 (declare (ignore component properties description
))
135 ;;;; * Object Presentations
136 (define-layered-method display-using-description
137 ((occurence standard-occurence
) component object properties
)
139 (with-plist (properties o
)
140 (loop for att in
(or (o-getp :attributes
) (list-slots object
))
141 do
(let* ((att (ensure-list att
))
142 (attribute (find-attribute occurence
(first att
))))
143 (warn "trying to render ~A in ~A" attribute object
)
144 (with-plist ((plist-union (rest att
) (find-plist attribute
)))
145 (<:p
:class
"attribute"
146 (<:span
:class
"label" (<:as-html
(getp :label
) " "))
147 (display-using-description
154 (defdisplay (:in-layer one-line
)
155 (do-attributes (attribute occurence
(or (getp :attributes
)
156 (list-slots object
)))
157 (display-using-description attribute component object
(attribute-properties))
162 (defdisplay (:in-layer as-table
)
164 (do-attributes (a occurence
(attributes))
166 (<:td
(<:as-html
(a-getp :label
)))
167 (<:td
(display-using-description a component object
(a-properties)))))))
172 :description
(desc t
))
175 (<:li
(apply #'display component item properties
)))))
180 (defdisplay (:in-layer
182 :description
(attribute standard-attribute
))
183 "Legacy editor using UCW presentations"
184 (let ((p (lol:make-view object
:type
:editor
)))
185 (present-slot-view p
(getf (find-plist attribute
) :slot-name
))))
187 (define-layered-method display-using-description
188 ((attribute standard-attribute
) component object properties
)
189 (let ((p (lol:make-view object
:type
'mewa-viewer
))
190 (name (attribute.name attribute
)))
191 (when name
(present-slot-view p name
))))
194 (button (eql 'standard-form-buttons
))
195 :description
(description t
))
196 (<ucw
:submit
:action
(ok component
)
200 (defdisplay (:in-layer wrap-form
201 :combination
:around
)
203 :action
(refresh-component component
)
205 (display component
'standard-form-buttons
)))
208 (defclass/meta test-class
()
209 ((test-string :initform
"test string" :type string
))
210 (:documentation
"foo"))
212 (define-attributes (test-class)
213 (test-string t
:label
"String :" :editablep t
))
215 (defcomponent test-component
()
216 ((display-types :accessor display-types
:initform
(list 'viewer
'editor
'creator
'one-line
'as-string
))
217 (current-type :accessor current-type
:initform
'viewer
)
218 (instance :accessor instance
:initform
(make-instance 'test-class
))))
220 (defmethod render ((self test-component
))
221 (let ((test (instance self
)))
222 (<:h1
(<:as-html
"Lisp on Lines Test Component"))
223 (with-component (self)
225 :action
(refresh-component self
)
226 (<ucw
:select
:accessor
(current-type self
)
227 (dolist* (type (display-types self
))
228 (<ucw
:option
:value type
(<:as-html type
))))
229 (<:input
:type
"Submit" :value
"update")
231 (<:legend
(<:as-html
(current-type self
)))
232 (display test
:type
(current-type self
)))))
236 (<:as-html
"UCW Presentation based displays (the old school"))
237 (dolist (type '(:viewer
:editor
:creator
:one-line
:as-string
))
238 (<:h3
(<:as-html type
))
239 (present-view (test type self
))
240 (<ucw
:a
:action
(call-view (test type self
))
241 (<:as-html
"Call to " type
))))))
244 (defcomponent standard-display-component
()
245 ((display-function :accessor display-function
:initarg
:display
)))
247 (defmethod render ((self standard-display-component
))
248 (funcall (display-function self
) self
))