1 (in-package :lisp-on-lines
)
3 (deflayer lisp-on-lines
())
5 ;;;; The Standard Layers
6 (deflayer viewer
(lisp-on-lines))
7 (deflayer editor
(lisp-on-lines))
12 ((attribute standard-attribute
) object
)
16 ((attribute standard-attribute
) object component
)
17 (<:as-html
(attribute-value object attribute
)))
19 (define-layered-method display-using-description
20 ((attribute standard-attribute
) object component
)
21 (with-component (component)
23 (<:as-html
(attribute-value object attribute
)))
25 (define-layered-method label
(anything)
29 :in-layer editor
:around
(description object
)
30 "It is useful to remove the viewer layer when in the editing layer.
31 This allows us to dispatch to a subclasses editor.
33 (with-inactive-layers (viewer)
36 ;;;; These layers affect the layout of the object
42 :in-layer as-string
(d o
(self t
))
43 (with-output-to-string (yaclml::*yaclml-stream
*)
45 (display-attribute a o
)
47 #+nil
(with-inactive-layers (editor viewer one-line as-table show-attribute-labels
)
52 :in-layer as-string
(d o
)
53 (with-output-to-string (yaclml::*yaclml-stream
*)
55 (display-attribute a o
)
57 #+nil
(with-inactive-layers (editor viewer one-line as-table show-attribute-labels
)
60 (defmethod list-slots (thing)
63 ;;;; * Object displays.
67 ;;;; TODO: all lisp types should have occurences and attributes defined for them.
69 (defdisplay ((description t
) lisp-value
)
70 (<:as-html lisp-value
))
72 (defdisplay (description (object string
))
75 (defdisplay (description (object symbol
))
78 (defdisplay (description object
(component t
))
79 "The default display for CLOS objects"
80 (print (class-name (class-of object
)))
81 (dolist* (slot-name (list-slots object
))
82 (let ((boundp (slot-boundp object slot-name
)))
83 (format t
"~A~A : ~A" (strcat slot-name
)
88 (slot-value object slot-name
) "")))))
90 (defdisplay ((description t
) object
)
91 "The default display for CLOS objects in UCW components"
92 (dolist* (slot-name (list-slots object
))
94 (let ((boundp (slot-boundp object slot-name
)))
95 (<:label
:class
"lol-label"
96 (display-attribute 'label
(strcat slot-name
))
102 (slot-value object slot-name
) "")))))
104 ;;;; ** The default displays for objects with a MEWA occurence
106 (defdisplay (description object
)
109 (when (label description
)
112 (<:as-html
(label description
))))
113 (do-attributes (attribute description
)
116 (display-attribute attribute object
)))))
120 :in-layer one-line
(description object
)
121 "The one line presentation just displays the attributes with a #\Space between them"
122 (do-attributes (attribute description
)
123 (display-attribute attribute object
)
128 (defdisplay :in-layer as-table
(description object
)
130 (do-attributes (a description
)
132 (<:td
:class
"lol-label" (<:as-html
(label a
)))
133 (<:td
(display-attribute a object
))))))
137 #|
(deflayer list-display-layer
)
139 (define-layered-class description
140 :in-layer list-display-layer
()
141 ((list-item :initarg
:list-item
145 :accessor list-item
)))
147 (defdisplay (desc (list list
))
148 (with-active-layers (list-display-layer)
151 (<:li
(apply #'display
* item
(list-item desc
)))))))
153 (defdisplay :in-layer as-table
(description (list list
))
154 (with-active-layers (list-display-layer)
155 (let ((item-description (find-occurence (first list
))))
158 (apply #'lol
::make-display-function self
(first list
)
159 (list-item description
))
160 (lambda (desc item component
)
162 (do-attributes (a desc
)
163 (<:th
(<:as-html
(label a
)))))
167 (do-attributes (a desc
)
168 (<:td
(display-attribute a obj
))))))))))) |
#