Form types
[clinton/lisp-on-lines.git] / src / attributes / standard-attributes.lisp
CommitLineData
7733a777
DC
1(in-package :lisp-on-lines)
2
e1645f63 3;;;; A few layers related to attributes
2b0fd9c8
DC
4(deflayer omit-nil-attributes)
5
6(defdisplay :in-layer omit-nil-attributes
7 :around ((attribute standard-attribute) object)
8 (when (attribute-value object attribute)
9 (call-next-method)))
10
e1645f63 11(deflayer show-attribute-labels)
2b0fd9c8 12
e1645f63 13(defdisplay
14 :in-layer show-attribute-labels
e4f96295 15 :around ((attribute standard-attribute) object)
fb04c0a8 16 (<:label
e1645f63 17 :class "lol-label"
18 (<:as-html (or (label attribute) (attribute.name attribute)) " "))
19 (<:span
20 :class "lol-attribute"
21 (call-next-method)))
22
23(deflayer use-pretty-labels)
24
25(define-layered-method label
26 :in-layer use-pretty-labels
27 :around (standard-attribute)
28 (let ((label (call-next-method)))
29 (when label
30 (string-capitalize
31 (substitute #\Space #\- label)))))
32
e4f96295 33(deflayer inspect-attributes)
34
35(defdisplay :in-layer inspect-attributes
36 :around ((attribute standard-attribute) object)
37 (call-next-method)
38 (<ucw:a :action (ucw::call-inspector self attribute)
39 :title
40 (strcat "Inspect "
41 (attribute.name attribute) ":"
42 (description.type attribute) ":"
43 (type-of attribute))
44 (<:as-html "(i)")))
45
46;;;; Functional attributes
47(defattribute display-attribute ()
48 ((display-arguments
49 :accessor display-arguments
50 :initarg :display
51 :special t
52 :initform nil))
53 (:type-name display)
e1645f63 54 (:documentation "Apply the display function to this object"))
2b0fd9c8 55
e4f96295 56(defdisplay ((attribute display-attribute) object)
e1645f63 57 (apply #'display self (attribute-value object attribute)
e4f96295 58 (display-arguments attribute)))
2b0fd9c8 59
e4f96295 60(defattribute function-attribute ()
61 ((function :accessor function-of
62 :initarg :function
63 :initform #'funcall
64 :special t))
65 (:type-name function)
66 (:documentation ""))
2b0fd9c8 67
e4f96295 68(defdisplay ((function function-attribute) object)
69 (funcall (function-of function)
70 (attribute-value object function)))
2b0fd9c8 71
2b0fd9c8 72
e4f96295 73;;;; Attribute Grouping
74(defattribute attribute-group ()
9af22ce3 75 ()
a4e6154d 76 (:default-properties
e4f96295 77 :group nil)
78 (:type-name group))
e1645f63 79
e4f96295 80(defdisplay ((group attribute-group) object)
81 (apply #'display self object
82 :attributes (attributes group)
83 (group group)))
e1645f63 84
fb04c0a8 85
86(defattribute select-attribute (display-attribute)
87 ()
88 (:default-properties
89 :test 'meta-model::generic-equal
90 :options-getter (constantly nil))
91 (:type-name select))
92
93(defdisplay ((attribute select-attribute) object)
94 (<ucw:select
95 :accessor (attribute-value object attribute)
96
97 :test (test attribute)
98 (dolist* (obj (funcall (options-getter attribute) object))
99 (<ucw:option
100 :value obj
101 (apply #'display* obj (display-arguments attribute))))))
102
e4f96295 103;;;; * Base Types
e1645f63 104
e4f96295 105(defattribute base-attribute ()
106 ()
107 (:default-properties
108 :default-value ""))
e1645f63 109
e4f96295 110(defdisplay ((base base-attribute) object)
111 (<:as-html (attribute-value object base)))
e1645f63 112
fb04c0a8 113(defattribute base-attribute ()
e4f96295 114 ()
115 (:in-layer editor)
116 (:default-properties
117 :callback nil
118 :default-value nil
fb04c0a8 119 :default-value-predicate #'null
120 :dom-id (js:gen-js-name-string :prefix "_ucw_")
121 :input-size nil))
e1645f63 122
e4f96295 123(define-layered-function display-value (attribute value)
124 (:method (attribute value)
125 (if (funcall (default-value-predicate attribute) value)
126 (default-value attribute)
127 value)))
e1645f63 128
129(defdisplay
e4f96295 130 :in-layer editor ((field base-attribute) object)
131 (LET ((value (attribute-value (object field) field)))
132 (<:input
133 :NAME
134 (callback field)
135 :VALUE (escape-as-html (strcat (display-value field value)))
136 :TYPE
137 "text"
138 :ID
139 (DOM-ID FIELD)
140 :SIZE
fb04c0a8 141 (INPUT-SIZE FIELD))))
e1645f63 142
a4e6154d
DC
143(defdisplay
144 :in-layer editor :around ((string base-attribute) object)
e4f96295 145 (dletf (((callback string)
146 (or (callback string)
147 (ucw::make-new-callback
148 #'(lambda (val)
149 (setf (attribute-value object string) val)))))
e1645f63 150 ((object string) object))
a4e6154d 151 (call-next-method)))
2b0fd9c8 152
a4e6154d
DC
153;;;; Strings
154
e1645f63 155(defattribute string-attribute (base-attribute)
a4e6154d 156 ()
9af22ce3
DC
157 (:type-name string)
158 (:default-properties
2b0fd9c8
DC
159 :escape-html-p t
160 :size nil
e4f96295 161 :max-length nil
162 :default-value ""))
9af22ce3 163
2b0fd9c8
DC
164(defdisplay :in-layer omit-nil-attributes
165 :around ((attribute string-attribute) object)
166 (when (< 0 (length (attribute-value object attribute)))
167 (call-next-method)))
168
2b0fd9c8 169;;;; default
a4e6154d
DC
170(defdisplay :in-layer viewer
171 ((string string-attribute) object)
2b0fd9c8 172 (if (escape-html-p string)
9af22ce3
DC
173 (<:as-html (attribute-value object string))
174 (<:as-is (attribute-value object string))))
175
176
2b0fd9c8
DC
177;;;; editor
178(defattribute string-attribute (base-attribute)
179 ()
180 (:in-layer editor)
181 (:default-properties
182 :callback nil))
183
a4e6154d 184
2b0fd9c8
DC
185(defattribute string-search-attribute (string-attribute)
186 ()
187 (:default-properties
188 ;; the func that find search results
189
190 :search-action #'(lambda ()
191 (with-call/cc
192 nil))
193 ;; when chosing from a list of results, this function selects one.
194 :select-function (constantly t))
195 (:type-name string-search))
196
197(defdisplay
198 :in-layer editor :after ((search string-search-attribute) object)
a4e6154d
DC
199 (<:input
200 :TYPE "submit"
201 :VALUE "search"
202 :ONCLICK
203 (JS:JS-INLINE*
204 `(PROGN
205 (IT.BESE.UCW::SET-ACTION-PARAMETER
206 ,(IT.BESE.UCW::MAKE-NEW-ACTION
207 (IT.BESE.UCW::CONTEXT.CURRENT-FRAME *CONTEXT*)
208 (search-action search)))
209 (RETURN T)))))
2b0fd9c8
DC
210
211;;;; textarea
212
213(defattribute text-attribute (string-attribute)
a4e6154d
DC
214 ()
215 (:type-name text))
2b0fd9c8
DC
216
217(defdisplay :in-layer editor ((string text-attribute) object)
218 (<:textarea
e4f96295 219 :id (dom-id string)
2b0fd9c8 220 :name (callback string)
a4e6154d 221 (or (attribute-value object string) "")))
2b0fd9c8
DC
222
223
224
225;;;; WALL-TIME
226
227(defattribute wall-time-attribute (string-attribute)
228 ()
229 (:type-name clsql-sys:wall-time))
230
231(define-layered-method attribute-value (object (attribute wall-time-attribute))
232 (let ((date (call-next-method)))
233 (when date (multiple-value-bind (y m d) (clsql:time-ymd date)
234 (format nil "~a/~a/~a" m d y)))))
235
236(defdisplay
237 ((time wall-time-attribute) object)
238 (<:as-html (attribute-value object time)))
239
240
241
7733a777 242(defattribute image ()
a4e6154d
DC
243 ()
244 (:default-properties
245 :css-class "lol-image"
246 :prefix "images/"))
7733a777 247
2b0fd9c8 248(defdisplay ((buttons (eql 'image-editor-buttons)) object)
60a24293
DC
249 (<ucw:a :action (ok component object)
250 (<:as-html "select this image")))
251
2b0fd9c8 252(defdisplay ((image image) object)
7733a777 253 (<:img
a4e6154d 254 :class (or (css-class image) "lol-image")
7733a777 255 :src (arnesi:strcat
a4e6154d 256 (or (prefix image) "images/")
7733a777
DC
257 (escape-as-uri
258 (attribute-value object image)))))
259
2b0fd9c8
DC
260(defdisplay
261 :in-layer editor ((image image) object)
262
60a24293 263 (<:div
2b0fd9c8 264 :class "lol-image-thumbnails"
a4e6154d 265 (<:as-html "imagie")))
60a24293 266
7733a777
DC
267
268
269
270
271