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 ucw-core
:component
) string
&rest args
)
8 (<:as-html
(with-output-to-string (stream)
9 (apply #'call-next-method stream string args
))))
11 (define-description html-description
()
14 (define-description t
()
15 ((css-class :value
"lol-description" :activep nil
)
16 (dom-id :function
(lambda (x)
21 (:in-description html-description
))
23 (define-layered-class html-attribute
()
24 ((css-class :accessor attribute-css-class
25 :initform
"lol-attribute")
26 (dom-id :accessor attribute-dom-id
:initform nil
)
27 (value-tag :accessor attribute-html-tag
:initform nil
:initarg
:html-tag
)
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
)))
51 (<:as-html
(display-attribute-label attribute
))))))
53 (define-layered-function display-html-attribute-value
(object attribute
)
54 (:method
(object attribute
)
57 :class
"lol-attribute-value"
59 (display-attribute-value attribute
))))
62 :in-layer
#.
(defining-description 'inline
) (object attribute
)
63 (display-attribute-value attribute
)))
66 (define-layered-function display-html-attribute
(object attribute
)
68 (:method
(object attribute
)
70 :class
(format nil
"~A lol-attribute" (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 (<:span
:class
"lol-attribute-label"
84 (display-html-attribute-label object attribute
))
85 (<:span
:class
"lol-attribute-value"
86 (display-html-attribute-value object attribute
)))))
88 (define-layered-method display-using-description
89 :in-layer
#.
(defining-description 'html-description
)
90 :around
((attribute standard-attribute
) display object
&rest args
)
91 (declare (ignore args
))
92 (display-html-attribute object attribute
))
95 (defun capture-description (attribute function
)
96 (let ((obj (described-object (attribute-description attribute
))))
98 (dletf (((described-object attribute
) obj
))
99 (apply function args
)))))
101 (defun make-attribute-value-writer (attribute)
102 (let ((obj (described-object (attribute-description attribute
)))
103 (value (attribute-value attribute
)))
105 (dletf (((described-object attribute
) obj
))
106 (with-active-descriptions (editable)
107 (unless (and (unbound-slot-value-p value
)
109 (setf (attribute-value attribute
)
110 (parse-attribute-value attribute val
))))))))
113 (defmethod html-attribute-value (attribute)
114 (let ((val (attribute-value attribute
)))
115 (if (unbound-slot-value-p val
)
119 (defmethod display-html-attribute-editor (attribute editor
)
120 (<ucw
:input
:type
"text"
121 :reader
(html-attribute-value attribute
)
122 :writer
(make-attribute-value-writer attribute
)))
124 (defmethod display-html-attribute-editor ((attribute slot-definition-attribute
) editor
)
127 (defmethod display-html-attribute-editor (attribute (editor password-attribute-editor
))
128 (<ucw
:input
:type
"password"
129 :reader
(html-attribute-value attribute
)
130 :writer
(make-attribute-value-writer attribute
)))
135 (define-layered-method display-attribute-editor
136 :in-layer
#.
(defining-description 'html-description
) (attribute)
137 (display-html-attribute-editor attribute
(attribute-editor attribute
)))
140 (define-layered-method display-html-attribute-value
141 :in-layer
#.
(defining-description 'editable
) (object attribute
)
144 (if (attribute-editp attribute
)
146 :class
"lol-attribute-value"(display-attribute-editor attribute
))
149 (define-layered-function display-html-description
(description display object
&optional next-method
)
150 (:method
(description display object
&optional
(next-method #'display-using-description
))
153 (with-attributes (css-class dom-id
) description
157 :class
(list (attribute-value css-class
) "lol-description" "t")
158 :id
(attribute-value dom-id
)
159 (funcall next-method
)
160 (<:br
:class
"clear")))))
163 (define-layered-method display-html-description
164 :in-layer
#.
(defining-description 'inline
) (description display object
&optional next-method
)
165 (with-attributes (css-class dom-id
) description
167 :class
(list (attribute-value css-class
) "lol-description")
168 :id
(attribute-value dom-id
)
169 (funcall next-method
))))
173 :in-description html-description
((description t
)
174 (display ucw-core
:component
)
176 (display-html-description description display object
(lambda ()
177 (call-next-method))))
179 (define-layered-method display-html-attribute-value
180 (object (attribute list-attribute
))
181 (let ((val (attribute-value attribute
)))
184 (arnesi:dolist
* (item (attribute-value attribute
))
186 (dletf (((attribute-object attribute
) item
))
187 (<:li
(apply #'display
*display
* item
(slot-value attribute
'item-args
)))))))))