1 (in-package :lisp-on-lines
)
3 ;;;; The Standard Layers
8 :in-layer editor
:around
(description object
)
9 "It is useful to remove the viewer layer when in the editing layer.
10 This allows us to dispatch to a subclasses editor."
11 (with-inactive-layers (viewer)
23 :in-layer as-string
(d o
)
24 (with-inactive-layers (editor viewer creator one-line as-table label-attributes
)
26 (display-attribute a o
)
29 (defmethod list-slots (thing)
33 ;;;; TODO : this doesn't work
35 (defaction call-display-with-context
((from component
) object context
&rest properties
)
36 (call-component self
(make-instance 'standard-display-component
39 :args
(if (cdr properties
)
43 (defmacro call-display
(component object
&rest properties
)
45 (call-display-with-context ,component
,object nil
,@properties
)))
47 (defcomponent standard-display-component
()
48 ((context :accessor context
:initarg
:context
)
49 (object :accessor object
:initarg
:object
)
50 (args :accessor args
:initarg
:args
)))
52 (defmethod render ((self standard-display-component
))
54 (apply #'display self
(object self
) (args self
)))
57 ;;;; * Object displays.
61 ;;;; TODO: all lisp types should have occurences and attributes defined for them.
63 (defdisplay ((description t
) lisp-value
)
64 (<:as-html lisp-value
))
66 (defdisplay (description (object string
))
69 (defdisplay (description object
(component t
))
70 "The default display for CLOS objects"
71 (print (class-name (class-of object
)))
72 (dolist* (slot-name (list-slots object
))
74 (let ((boundp (slot-boundp object slot-name
)))
75 (format t
"~A~A : ~A" (strcat slot-name
)
80 (slot-value object slot-name
) "")))))
82 (defdisplay ((description t
) object
)
83 "The default display for CLOS objects in UCW components"
84 (dolist* (slot-name (list-slots object
))
86 (let ((boundp (slot-boundp object slot-name
)))
87 (<:label
:class
"lol-label"
88 (display-attribute 'label
(strcat slot-name
))
94 (slot-value object slot-name
) "")))))
96 ;;;; ** The default displays for objects with a MEWA occurence
98 (defdisplay (description object
)
101 (when (label description
)
104 (<:as-html
(label description
))))
105 (do-attributes (attribute description
)
108 (display-attribute attribute object
)))))
112 :in-layer one-line
(description object
)
113 "The one line presentation just displays the attributes with a #\Space between them"
114 (do-attributes (attribute description
)
115 (display-attribute attribute object
)
120 (defdisplay :in-layer as-table
(description object
)
122 (do-attributes (a description
)
124 (<:td
:class
"lol-label" (<:as-html
(label a
)))
125 (<:td
(display-attribute a object
))))))
128 (defdisplay (desc (list list
))
131 (<:li
(display* item
)
137 ((attribute standard-attribute
) object
)
138 "Legacy editor using UCW presentations"
140 (warn "USING LEGACY EDITOR FOR ~A" (slot-name attribute
)))
142 (define-layered-method display-using-description
143 ((attribute standard-attribute
) object component
)
144 (with-component (component)
145 (<ucw
:a
:action
(call 'info-message
:message
(strcat (symbol-package (description.type attribute
))":/::" (description.type attribute
)))
147 (<:as-html
(attribute-value object attribute
)))