1 (in-package :lisp-on-lines
)
3 ;;;; The Standard Layers
7 (define-layered-method label
(anything)
11 :in-layer editor
:around
(description object
)
12 "It is useful to remove the viewer layer when in the editing layer.
13 This allows us to dispatch to a subclasses editor.
15 (with-inactive-layers (viewer)
18 ;;;; These layers affect the layout of the object
24 :in-layer as-string
(d o
)
25 (with-inactive-layers (editor viewer one-line as-table show-attribute-labels
)
27 (display-attribute a o
)
30 (defmethod list-slots (thing)
33 ;;;; * Object displays.
37 ;;;; TODO: all lisp types should have occurences and attributes defined for them.
39 (defdisplay ((description t
) lisp-value
)
40 (<:as-html lisp-value
))
42 (defdisplay (description (object string
))
45 (defdisplay (description (object symbol
))
48 (defdisplay (description object
(component t
))
49 "The default display for CLOS objects"
50 (print (class-name (class-of object
)))
51 (dolist* (slot-name (list-slots object
))
53 (let ((boundp (slot-boundp object slot-name
)))
54 (format t
"~A~A : ~A" (strcat slot-name
)
59 (slot-value object slot-name
) "")))))
61 (defdisplay ((description t
) object
)
62 "The default display for CLOS objects in UCW components"
63 (dolist* (slot-name (list-slots object
))
65 (let ((boundp (slot-boundp object slot-name
)))
66 (<:label
:class
"lol-label"
67 (display-attribute 'label
(strcat slot-name
))
73 (slot-value object slot-name
) "")))))
75 ;;;; ** The default displays for objects with a MEWA occurence
77 (defdisplay (description object
)
80 (when (label description
)
83 (<:as-html
(label description
))))
84 (do-attributes (attribute description
)
87 (display-attribute attribute object
)))))
91 :in-layer one-line
(description object
)
92 "The one line presentation just displays the attributes with a #\Space between them"
93 (do-attributes (attribute description
)
94 (display-attribute attribute object
)
99 (defdisplay :in-layer as-table
(description object
)
101 (do-attributes (a description
)
103 (<:td
:class
"lol-label" (<:as-html
(label a
)))
104 (<:td
(display-attribute a object
))))))
108 (deflayer list-display-layer
)
110 (define-layered-class description
111 :in-layer list-display-layer
()
112 ((list-item :initarg
:list-item
116 :accessor list-item
)))
118 (defdisplay (desc (list list
))
119 (with-active-layers (list-display-layer)
122 (<:li
(apply #'display
* item
(list-item desc
)))))))
124 (defdisplay :in-layer as-table
(description (list list
))
125 (with-active-layers (list-display-layer)
126 (let ((item-description (find-occurence (first list
))))
129 (apply #'lol
::make-display-function self
(first list
)
130 (list-item description
))
131 (lambda (desc item component
)
133 (do-attributes (a desc
)
134 (<:th
(<:as-html
(label a
)))))
138 (do-attributes (a desc
)
139 (<:td
(display-attribute a obj
)))))))))))
144 ((attribute standard-attribute
) object
)
147 (define-layered-method display-using-description
148 ((attribute standard-attribute
) object component
)
149 (with-component (component)
150 (<ucw
:a
:action
(call 'info-message
:message
(strcat (symbol-package (description.type attribute
))":/::" (description.type attribute
)))
152 (<:as-html
(attribute-value object attribute
)))