tons of small changes to bring this up to date with maxclaims 2.0
[clinton/lisp-on-lines.git] / src / ucw / html-description.lisp
1 (in-package :lisp-on-lines)
2
3 (export '(html-description) (find-package :lisp-on-lines))
4
5 (defvar *escape-html* t)
6
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))))
10
11 (define-description html-description ()
12 ())
13
14 (define-description t ()
15 ((css-class :value "lol-description" :activep nil)
16 (dom-id :function (lambda (x)
17 (declare (ignore x))
18 (symbol-name
19 (gensym "DOM-ID-")))
20 :activep nil))
21 (:in-description html-description))
22
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)))
29
30 (define-layered-class standard-attribute
31 :in-layer #.(defining-description 'html-description)
32 (html-attribute)
33 ())
34
35 (define-layered-function display-html-attribute-label (object attribute)
36 (:method (object attribute)
37
38 (let ((label (attribute-label attribute)))
39 (when (or label (attribute-display-empty-label-p attribute))
40 (<:td (<:label
41 :class "lol-attribute-label"
42 (when label
43 (<:as-html
44 (with-output-to-string (*display*)
45 (display-attribute-label attribute)))))))))
46 (:method
47 :in-layer #.(defining-description 'inline)
48 (object attribute)
49 (let ((label (attribute-label attribute)))
50 (when label
51 (<:as-html (display-attribute-label attribute))))))
52
53 (define-layered-function display-html-attribute-value (object attribute)
54 (:method (object attribute)
55
56 (<:td
57 :class "lol-attribute-value"
58 (<:as-html
59 (display-attribute-value attribute))))
60
61 (:method
62 :in-layer #.(defining-description 'inline) (object attribute)
63 (display-attribute-value attribute)))
64
65
66 (define-layered-function display-html-attribute (object attribute)
67
68 (:method (object attribute)
69 (<:tr
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)))
75
76 (:method
77 :in-layer #.(defining-description 'inline)
78 (object attribute)
79 (<:span
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)))))
87
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))
93
94
95 (defun capture-description (attribute function)
96 (let ((obj (described-object (attribute-description attribute))))
97 (lambda (&rest args)
98 (dletf (((described-object attribute) obj))
99 (apply function args)))))
100
101 (defun make-attribute-value-writer (attribute)
102 (let ((obj (described-object (attribute-description attribute)))
103 (value (attribute-value attribute)))
104 (lambda (val)
105 (dletf (((described-object attribute) obj))
106 (with-active-descriptions (editable)
107 (unless (and (unbound-slot-value-p value)
108 (equal "" val))
109 (setf (attribute-value attribute)
110 (parse-attribute-value attribute val))))))))
111
112
113 (defmethod html-attribute-value (attribute)
114 (let ((val (attribute-value attribute)))
115 (if (unbound-slot-value-p val)
116 ""
117 val)))
118
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)))
123
124 (defmethod display-html-attribute-editor ((attribute slot-definition-attribute) editor)
125 (call-next-method))
126
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)))
131
132
133
134
135 (define-layered-method display-attribute-editor
136 :in-layer #.(defining-description 'html-description) (attribute)
137 (display-html-attribute-editor attribute (attribute-editor attribute)))
138
139
140 (define-layered-method display-html-attribute-value
141 :in-layer #.(defining-description 'editable) (object attribute)
142
143
144 (if (attribute-editp attribute)
145 (<:td
146 :class "lol-attribute-value"(display-attribute-editor attribute))
147 (call-next-method)))
148
149 (define-layered-function display-html-description (description display object &optional next-method)
150 (:method (description display object &optional (next-method #'display-using-description))
151
152
153 (with-attributes (css-class dom-id) description
154
155
156 (<:table
157 :class (list (attribute-value css-class) "lol-description" "t")
158 :id (attribute-value dom-id)
159 (funcall next-method)
160 (<:br :class "clear")))))
161
162
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
166 (<:span
167 :class (list (attribute-value css-class) "lol-description")
168 :id (attribute-value dom-id)
169 (funcall next-method))))
170
171
172 (define-display
173 :in-description html-description ((description t)
174 (display ucw-core:component)
175 object)
176 (display-html-description description display object (lambda ()
177 (call-next-method))))
178
179 (define-layered-method display-html-attribute-value
180 (object (attribute list-attribute))
181 (let ((val (attribute-value attribute)))
182 (when (listp val)
183 (<:ul
184 (arnesi:dolist* (item (attribute-value attribute))
185
186 (dletf (((attribute-object attribute) item))
187 (<:li (apply #'display *display* item (slot-value attribute 'item-args)))))))))