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
))
104 (desc (attribute-description attribute
)))
106 (dletf (((described-object (attribute-description attribute
)) obj
))
107 (with-active-descriptions (editable)
108 (unless (and (unbound-slot-value-p value
)
110 (with-described-object (obj desc
)
111 (setf (attribute-value attribute
)
112 (parse-attribute-value attribute val
)))))))))
115 (defmethod html-attribute-value (attribute)
116 (let ((val (attribute-value attribute
)))
117 (if (unbound-slot-value-p val
)
121 (defmethod display-html-attribute-editor (attribute editor
)
122 (<ucw
:input
:type
"text"
123 :reader
(html-attribute-value attribute
)
124 :writer
(make-attribute-value-writer attribute
)))
126 (defmethod display-html-attribute-editor ((attribute slot-definition-attribute
) editor
)
129 (defmethod display-html-attribute-editor (attribute (editor password-attribute-editor
))
130 (<ucw
:input
:type
"password"
131 :reader
(html-attribute-value attribute
)
132 :writer
(make-attribute-value-writer attribute
)))
134 (define-layered-method display-attribute-editor
135 :in-layer
#.
(defining-description 'html-description
) (attribute)
136 (display-html-attribute-editor attribute
(attribute-editor attribute
)))
139 (define-layered-method display-html-attribute-value
140 :in-layer
#.
(defining-description 'editable
) (object attribute
)
141 #+nil
(<:as-html
(princ-to-string (attribute-editp attribute
)))
142 (if (attribute-editp attribute
)
144 :class
"lol-attribute-value" (display-attribute-editor attribute
))
147 (define-layered-function display-html-description
(description display object
&optional next-method
)
148 (:method
(description display object
&optional
(next-method #'display-using-description
))
149 (let ((dom-id (find-attribute description
'dom-id
))
150 (css-class (find-attribute description
'dom-id
)))
152 :class
(list (attribute-value css-class
) "lol-description" "t")
153 :id
(attribute-value dom-id
)
154 (funcall next-method
)
155 (<:br
:class
"clear")))))
158 (define-layered-method display-html-description
159 :in-layer
#.
(defining-description 'inline
) (description display object
&optional next-method
)
160 (let ((dom-id (find-attribute description
'dom-id
))
161 (css-class (find-attribute description
'dom-id
)))
163 :class
(list (attribute-value css-class
) "lol-description")
164 :id
(attribute-value dom-id
)
165 (funcall next-method
))))
169 :in-description html-description
((description t
)
170 (display ucw-core
:component
)
172 (display-html-description description display object
(lambda ()
173 (call-next-method))))
175 (define-layered-method display-html-attribute-value
176 (object (attribute list-attribute
))
177 (let ((val (attribute-value attribute
)))
180 (arnesi:dolist
* (item (attribute-value attribute
))
182 (dletf (((attribute-object attribute
) item
))
183 (<:li
(apply #'display
*display
* item
(slot-value attribute
'item-args
)))))))))