Misc Cleanups.
[clinton/lisp-on-lines.git] / src / ucw / html-description.lisp
CommitLineData
4358148e 1(in-package :lisp-on-lines)
2
81d70610 3(export '(html-description) (find-package :lisp-on-lines))
4358148e 4
b7657b86 5(defvar *escape-html* t)
6
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))))
10
11
4358148e 12(define-description html-description ()
81d70610 13 ())
14
81d70610 15(define-description t ()
6de8d300 16 ((css-class :value "lol-description" :activep nil)
4358148e 17 (dom-id :function (lambda (x)
18 (declare (ignore x))
19 (symbol-name
6de8d300 20 (gensym "DOM-ID-")))
21 :activep nil))
4358148e 22 (:in-description html-description))
23
24(define-layered-class html-attribute ()
25 ((css-class :accessor attribute-css-class
26 :initform "lol-attribute")
2548f054 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)))
4358148e 29
30(define-layered-class standard-attribute
31 :in-layer #.(defining-description 'html-description)
32 (html-attribute)
33 ())
34
6de8d300 35(define-layered-function display-html-attribute-label (object attribute)
36 (:method (object attribute)
2548f054 37
6de8d300 38 (let ((label (attribute-label attribute)))
2548f054 39 (when (or label (attribute-display-empty-label-p attribute))
40 (<:td (<:label
6de8d300 41 :class "lol-attribute-label"
42 (when label
43 (<:as-html
44 (with-output-to-string (*display*)
2548f054 45 (display-attribute-label attribute)))))))))
b7657b86 46 (:method
47 :in-layer #.(defining-description 'inline)
48 (object attribute)
49 (let ((label (attribute-label attribute)))
50 (when label
2548f054 51 (<:as-html
b7657b86 52 (with-output-to-string (*display*)
53 (display-attribute-label attribute)))))))
6de8d300 54
55(define-layered-function display-html-attribute-value (object attribute)
56 (:method (object attribute)
2548f054 57 (<:td
6de8d300 58 :class "lol-attribute-value"
e8d4fa45 59 (<:as-html
b7657b86 60 (display-attribute-value attribute))))
61
62 (:method
63 :in-layer #.(defining-description 'inline) (object attribute)
64 (display-attribute-value attribute)))
6de8d300 65
66(define-layered-function display-html-attribute (object attribute)
b7657b86 67
6de8d300 68 (:method (object attribute)
2548f054 69 (<:tr
b7657b86 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)))
75
76 (:method
77 :in-layer #.(defining-description 'inline)
78 (object attribute)
79 (<:span
6de8d300 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)
b7657b86 84 (display-html-attribute-value object attribute))))
85
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))
91
92
2548f054 93(defun capture-description (attribute function)
94 (let ((obj (described-object (attribute-description attribute))))
95 (lambda (&rest args)
96 (dletf (((described-object attribute) obj))
97 (apply function args)))))
98
f4efa7ff 99(defun make-attribute-value-writer (attribute)
2548f054 100 (let ((obj (described-object (attribute-description attribute)))
101 (value (attribute-value attribute)))
f4efa7ff 102 (lambda (val)
103 (dletf (((described-object attribute) obj))
2548f054 104 (with-active-descriptions (editable)
105 (unless (and (unbound-slot-value-p value)
106 (equal "" val))
107 (setf (attribute-value attribute)
108 (parse-attribute-value attribute val))))))))
109
f4efa7ff 110
2548f054 111(defmethod html-attribute-value (attribute)
112 (let ((val (attribute-value attribute)))
113 (if (unbound-slot-value-p val)
114 ""
115 val)))
f4efa7ff 116
117(defmethod display-html-attribute-editor (attribute editor)
118 (<lol:input :type "text"
2548f054 119 :reader (html-attribute-value attribute)
f4efa7ff 120 :writer (make-attribute-value-writer attribute)))
121
2548f054 122(defmethod display-html-attribute-editor ((attribute slot-definition-attribute) editor)
123 (call-next-method))
124
f4efa7ff 125(defmethod display-html-attribute-editor (attribute (editor password-attribute-editor))
126 (<lol:input :type "password"
2548f054 127 :reader (html-attribute-value attribute)
f4efa7ff 128 :writer (make-attribute-value-writer attribute)))
129
130
ec6dde1e 131
132
f4efa7ff 133(define-layered-method display-attribute-editor
134 :in-layer #.(defining-description 'html-description) (attribute)
135 (display-html-attribute-editor attribute (attribute-editor attribute)))
136
6de8d300 137
138(define-layered-method display-html-attribute-value
139 :in-layer #.(defining-description 'editable) (object attribute)
140
2548f054 141 (<:td
6de8d300 142 :class "lol-attribute-value"
f4efa7ff 143 (if (attribute-editp attribute)
144 (display-attribute-editor attribute)
f4efa7ff 145 (call-next-method))))
6de8d300 146
b7657b86 147(define-layered-function display-html-description (description display object &optional next-method)
148 (:method (description display object &optional (next-method #'display-using-description))
6de8d300 149 (<:style
150 (<:as-html "
81d70610 151
2548f054 152
153
6de8d300 154div.lol-description .lol-attribute-label,
155div.lol-description .lol-attribute-value {
81d70610 156 display: block;
6de8d300 157 width: 69%;
81d70610 158 float: left;
6de8d300 159 margin-bottom: 1em;
2548f054 160border:1px solid black;
81d70610 161
162}
6de8d300 163div.lol-description
81d70610 164.lol-attribute-label {
165 text-align: right;
166 width: 24%;
2548f054 167 padding-right: 1em;
81d70610 168}
169
2548f054 170span.lol-attribute-value .lol-attribute-value (
171 border: 1px solid red;}
172
81d70610 173
6de8d300 174div.lol-description
81d70610 175br {
176clear: left;
2548f054 177}
178
179.clear {clear:left}"
180
181))
6de8d300 182
183 (with-attributes (css-class dom-id) description
184
81d70610 185
2548f054 186 (<:table
b7657b86 187 :class (list (attribute-value css-class) "lol-description" "t")
188 :id (attribute-value dom-id)
2548f054 189 (funcall next-method)
190 (<:br :class "clear")))))
6de8d300 191
192
193(define-layered-method display-html-description
b7657b86 194 :in-layer #.(defining-description 'inline) (description display object &optional next-method)
6de8d300 195 (with-attributes (css-class dom-id) description
6de8d300 196 (<:span
b7657b86 197 :class (list (attribute-value css-class) "lol-description")
198 :id (attribute-value dom-id)
199 (funcall next-method))))
200
6de8d300 201
202(define-display
e8d4fa45 203 :in-description html-description ((description t)
204 (display lol-ucw:component)
205 object)
b7657b86 206 (display-html-description description display object (lambda ()
207 (call-next-method))))
208
2548f054 209(define-layered-method display-html-attribute-value
210 (object (attribute list-attribute))
ec6dde1e 211 (let ((val (attribute-value attribute)))
212 (when (listp val)
213 (<:ul
214 (arnesi:dolist* (item (attribute-value attribute))
215 (<:li (apply #'display *display* item (slot-value attribute 'item-args))))))))