1 (in-package :lisp-on-lines
)
3 (export '(html-description) (find-package :lisp-on-lines
))
5 (defvar *escape-html
* t
)
7 (defmethod generic-format ((display lol-ucw
:component
) string
&rest args
)
8 (<:as-html
(with-output-to-string (stream)
9 (apply #'call-next-method stream string args
))))
12 (define-description html-description
()
15 (define-description t
()
16 ((css-class :value
"lol-description" :activep nil
)
17 (dom-id :function
(lambda (x)
22 (:in-description html-description
))
24 (define-layered-class html-attribute
()
25 ((css-class :accessor attribute-css-class
26 :initform
"lol-attribute")
27 (dom-id :accessor attribute-dom-id
:initform nil
)
28 (display-empty-label :accessor attribute-display-empty-label-p
:initarg
:display-empty-label-p
:initform t
)))
30 (define-layered-class standard-attribute
31 :in-layer
#.
(defining-description 'html-description
)
35 (define-layered-function display-html-attribute-label
(object attribute
)
36 (:method
(object attribute
)
38 (let ((label (attribute-label attribute
)))
39 (when (or label
(attribute-display-empty-label-p attribute
))
41 :class
"lol-attribute-label"
44 (with-output-to-string (*display
*)
45 (display-attribute-label attribute
)))))))))
47 :in-layer
#.
(defining-description 'inline
)
49 (let ((label (attribute-label attribute
)))
52 (with-output-to-string (*display
*)
53 (display-attribute-label attribute
)))))))
55 (define-layered-function display-html-attribute-value
(object attribute
)
56 (:method
(object attribute
)
58 :class
"lol-attribute-value"
60 (display-attribute-value attribute
))))
63 :in-layer
#.
(defining-description 'inline
) (object attribute
)
64 (display-attribute-value attribute
)))
66 (define-layered-function display-html-attribute
(object attribute
)
68 (:method
(object attribute
)
70 :class
(attribute-css-class attribute
)
71 (when (attribute-dom-id attribute
)
72 :id
(attribute-dom-id attribute
))
73 (display-html-attribute-label object attribute
)
74 (display-html-attribute-value object attribute
)))
77 :in-layer
#.
(defining-description 'inline
)
80 :class
(attribute-css-class attribute
)
81 (when (attribute-dom-id attribute
)
82 :id
(attribute-dom-id attribute
))
83 (display-html-attribute-label object attribute
)
84 (display-html-attribute-value object attribute
))))
86 (define-layered-method display-using-description
87 :in-layer
#.
(defining-description 'html-description
)
88 :around
((attribute standard-attribute
) display object
&rest args
)
89 (declare (ignore args
))
90 (display-html-attribute object attribute
))
93 (defun capture-description (attribute function
)
94 (let ((obj (described-object (attribute-description attribute
))))
96 (dletf (((described-object attribute
) obj
))
97 (apply function args
)))))
99 (defun make-attribute-value-writer (attribute)
100 (let ((obj (described-object (attribute-description attribute
)))
101 (value (attribute-value attribute
)))
103 (dletf (((described-object attribute
) obj
))
104 (with-active-descriptions (editable)
105 (unless (and (unbound-slot-value-p value
)
107 (setf (attribute-value attribute
)
108 (parse-attribute-value attribute val
))))))))
111 (defmethod html-attribute-value (attribute)
112 (let ((val (attribute-value attribute
)))
113 (if (unbound-slot-value-p val
)
117 (defmethod display-html-attribute-editor (attribute editor
)
118 (<lol
:input
:type
"text"
119 :reader
(html-attribute-value attribute
)
120 :writer
(make-attribute-value-writer attribute
)))
122 (defmethod display-html-attribute-editor ((attribute slot-definition-attribute
) editor
)
125 (defmethod display-html-attribute-editor (attribute (editor password-attribute-editor
))
126 (<lol
:input
:type
"password"
127 :reader
(html-attribute-value attribute
)
128 :writer
(make-attribute-value-writer attribute
)))
131 (define-layered-method display-attribute-editor
132 :in-layer
#.
(defining-description 'html-description
) (attribute)
133 (display-html-attribute-editor attribute
(attribute-editor attribute
)))
136 (define-layered-method display-html-attribute-value
137 :in-layer
#.
(defining-description 'editable
) (object attribute
)
140 :class
"lol-attribute-value"
141 (if (attribute-editp attribute
)
142 (display-attribute-editor attribute
)
143 (call-next-method))))
145 (define-layered-function display-html-description
(description display object
&optional next-method
)
146 (:method
(description display object
&optional
(next-method #'display-using-description
))
152 div.lol-description .lol-attribute-label,
153 div.lol-description .lol-attribute-value {
158 border:1px solid black;
162 .lol-attribute-label {
168 span.lol-attribute-value .lol-attribute-value (
169 border: 1px solid red;}
181 (with-attributes (css-class dom-id
) description
185 :class
(list (attribute-value css-class
) "lol-description" "t")
186 :id
(attribute-value dom-id
)
187 (funcall next-method
)
188 (<:br
:class
"clear")))))
191 (define-layered-method display-html-description
192 :in-layer
#.
(defining-description 'inline
) (description display object
&optional next-method
)
193 (with-attributes (css-class dom-id
) description
195 :class
(list (attribute-value css-class
) "lol-description")
196 :id
(attribute-value dom-id
)
197 (funcall next-method
))))
201 :in-description html-description
((description t
)
202 (display lol-ucw
:component
)
204 (display-html-description description display object
(lambda ()
205 (call-next-method))))
207 (define-layered-method display-html-attribute-value
208 (object (attribute list-attribute
))
210 (arnesi:dolist
* (item (attribute-value attribute
))
211 (<:li
(apply #'display
*display
* item
(slot-value attribute
'item-args
))))))