1 (in-package :lisp-on-lines
)
3 ;;;; The Standard Layers
10 ((attribute standard-attribute
) object
)
14 ((attribute standard-attribute
) object component
)
15 (<:as-html
(attribute-value object attribute
)))
17 (define-layered-method display-using-description
18 ((attribute standard-attribute
) object component
)
19 (with-component (component)
21 (<:as-html
(attribute-value object attribute
)))
23 (define-layered-method label
(anything)
27 :in-layer editor
:around
(description object
)
28 "It is useful to remove the viewer layer when in the editing layer.
29 This allows us to dispatch to a subclasses editor.
31 (with-inactive-layers (viewer)
34 ;;;; These layers affect the layout of the object
40 :in-layer as-string
(d o
(self t
))
41 (with-output-to-string (yaclml::*yaclml-stream
*)
43 (display-attribute a o
)
45 #+nil
(with-inactive-layers (editor viewer one-line as-table show-attribute-labels
)
50 :in-layer as-string
(d o
)
51 (with-output-to-string (yaclml::*yaclml-stream
*)
53 (display-attribute a o
)
55 #+nil
(with-inactive-layers (editor viewer one-line as-table show-attribute-labels
)
58 (defmethod list-slots (thing)
61 ;;;; * Object displays.
65 ;;;; TODO: all lisp types should have occurences and attributes defined for them.
67 (defdisplay ((description t
) lisp-value
)
68 (<:as-html lisp-value
))
70 (defdisplay (description (object string
))
73 (defdisplay (description (object symbol
))
76 (defdisplay (description object
(component t
))
77 "The default display for CLOS objects"
78 (print (class-name (class-of object
)))
79 (dolist* (slot-name (list-slots object
))
80 (let ((boundp (slot-boundp object slot-name
)))
81 (format t
"~A~A : ~A" (strcat slot-name
)
86 (slot-value object slot-name
) "")))))
88 (defdisplay ((description t
) object
)
89 "The default display for CLOS objects in UCW components"
90 (dolist* (slot-name (list-slots object
))
92 (let ((boundp (slot-boundp object slot-name
)))
93 (<:label
:class
"lol-label"
94 (display-attribute 'label
(strcat slot-name
))
100 (slot-value object slot-name
) "")))))
102 ;;;; ** The default displays for objects with a MEWA occurence
104 (defdisplay (description object
)
107 (when (label description
)
110 (<:as-html
(label description
))))
111 (do-attributes (attribute description
)
114 (display-attribute attribute object
)))))
118 :in-layer one-line
(description object
)
119 "The one line presentation just displays the attributes with a #\Space between them"
120 (do-attributes (attribute description
)
121 (display-attribute attribute object
)
126 (defdisplay :in-layer as-table
(description object
)
128 (do-attributes (a description
)
130 (<:td
:class
"lol-label" (<:as-html
(label a
)))
131 (<:td
(display-attribute a object
))))))
135 #|
(deflayer list-display-layer
)
137 (define-layered-class description
138 :in-layer list-display-layer
()
139 ((list-item :initarg
:list-item
143 :accessor list-item
)))
145 (defdisplay (desc (list list
))
146 (with-active-layers (list-display-layer)
149 (<:li
(apply #'display
* item
(list-item desc
)))))))
151 (defdisplay :in-layer as-table
(description (list list
))
152 (with-active-layers (list-display-layer)
153 (let ((item-description (find-occurence (first list
))))
156 (apply #'lol
::make-display-function self
(first list
)
157 (list-item description
))
158 (lambda (desc item component
)
160 (do-attributes (a desc
)
161 (<:th
(<:as-html
(label a
)))))
165 (do-attributes (a desc
)
166 (<:td
(display-attribute a obj
))))))))))) |
#