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 (declare (ignorable self
))
25 (flet ((display* (thing &rest args
)
26 (apply #'display
,component thing args
))
27 (display-using-description* (desc obj
&optional props
)
28 (display-using-description desc
,component obj props
)))
29 (declare (ignorable #'display
* #'display-using-description
*))
33 (define-layered-function find-display-type
(object))
35 (define-layered-method find-display-type
(object)
38 (define-layered-function find-display-layers
(object))
40 (define-layered-method find-display-layers
(object)
44 (defmacro call-display
(component object
&rest args
)
45 `(call-component ,component
(make-instance 'standard-display-component
46 :display
#'(lambda (component)
47 (with-component (component)
48 (display ,component
,object
,@args
))))))
52 ;;;; * Object displays.
54 ;;;; We like to have a label for attributes, and meta-model provides a default.
56 (:description
(d (eql 'attribute-label
)))
62 (define-layered-function display
(component object
&rest args
)
64 "Displays OBJECT in COMPONENT.
66 default action is to FUNCALL-WITH-LAYERS the DISPLAY-USING-DESCRIPTION method."))
68 (define-layered-method display
69 ((component t
) (object standard-object
) &rest args
&key layers
(type 'viewer
) &allow-other-keys
)
70 (let* ((occurence (find-occurence object
))
71 (properties (attribute.properties
72 (find-attribute occurence
(intern (format nil
"~A" type
) :KEYWORD
))))
73 (layers (append (when type
(loop for ty in
(ensure-list type
)
76 (getf properties
:layers
))))
79 #'display-using-description occurence component object
(plist-union args properties
))))
82 (define-layered-method display
83 ((component t
) (object t
) &rest args
&key layers
(type 'viewer
) &allow-other-keys
)
86 #'display-using-description t component object args
))
89 (define-layered-function display-using-description
(description component object properties
)
91 "Render the object in component, using DESCRIPTION, which is an occurence, and attribute, or something else"))
93 (define-layered-method display-using-description
(description component object properties
)
94 "The standard display simply prints the object"
95 (declare (ignore component properties description
))
100 ;;;; ** The default display
105 (defdisplay object
(:in-layer one-line
)
106 "The one line presentation just displays the attributes with a #\Space between them"
107 (do-attributes* (attribute)
108 (display-current-attribute)
113 (defdisplay object
(:in-layer as-table
)
117 (<:td
(<:as-html
(a-getp :label
)))
118 (<:td
(display-current-attribute))))))
121 (defdisplay (list list
) ()
124 (<:li
(apply #'display component item properties
)))))
127 (defdisplay object
(:in-layer
129 :description
(attribute standard-attribute
))
130 "Legacy editor using UCW presentations"
131 (warn "USING LEGACY EDITOR FOR ~A" (getf (find-properties attribute
) :slot-name
))
132 (let ((p (lol:make-view object
:type
:editor
)))
133 (present-slot-view p
(getf (find-properties attribute
) :slot-name
))))
135 (define-layered-method display-using-description
136 ((attribute standard-attribute
) component object properties
)
137 (<:as-html
(attribute.type attribute
) " ")
139 (<:as-html
(attribute-value object attribute
)))
141 (defdisplay (button (eql 'standard-form-buttons
))
142 (:description
(description t
))
143 (<ucw
:submit
:action
(ok component
)
146 (defdisplay object
(:in-layer wrap-form
147 :combination
:around
)
149 :action
(refresh-component component
)
151 (display component
'standard-form-buttons
)))
154 (defcomponent standard-display-component
()
155 ((display-function :accessor display-function
:initarg
:display
)))
157 (defmethod render ((self standard-display-component
))
158 (funcall (display-function self
) self
))