d7e874d7abbe0870684d91066ad3edbd3b7e8c60
[clinton/lisp-on-lines.git] / src / slot-presentations.lisp
1 (in-package :lisp-on-lines)
2
3 (defun multiple-value-funcall->list (function &rest args)
4 "The function to be called by m-v-bf"
5 (multiple-value-call #'list (apply function args)))
6
7 (defmacro multiple-value-bindf (vars form &body body)
8 "Like M-V-B, only it works in actions. form must be a function call"
9 `(destructuring-bind ,vars
10 (multiple-value-funcall->list #',(car form) ,@(cdr form))
11 ,@body))
12
13
14 ;;;; ** Textarea Slot Presentation
15
16 (defslot-presentation text-slot-presentation ()
17 ((rows :initarg :rows :accessor rows :initform 5)
18 (columns :initarg :columns :accessor columns :initform 40)
19 (escape-html-p :initarg :escape-html-p :accessor escape-html-p :initform nil)
20 (convert-newlines-p :initarg :convert-newlines-p :accessor convert-newlines-p :initform nil))
21 (:type-name text))
22
23 (defmethod present-slot ((slot text-slot-presentation) instance)
24 (flet ((maybe-convert-newline-and-escape-html-then-print ()
25 (let ((string (if (convert-newlines-p slot)
26 (with-output-to-string (new-string)
27 (with-input-from-string
28 (s (presentation-slot-value slot instance))
29 (loop for line = (read-line s nil)
30 while line
31 do (format new-string "~A~A" line "<br/>"))))
32 (presentation-slot-value slot instance))))
33 (if (escape-html-p slot)
34 (<:as-html string)
35 (<:as-is string)))))
36
37 (if (editablep slot)
38 (<ucw:textarea
39 :accessor (presentation-slot-value slot instance)
40 :reader (or (presentation-slot-value slot instance)
41 "")
42 :rows (rows slot)
43 :cols (columns slot))
44 (maybe-convert-newline-and-escape-html-then-print))))
45
46
47 (defcomponent mewa-slot-presentation ()
48 ((slot-name :accessor slot-name
49 :initarg :slot-name
50 :documentation
51 "The name of the slot being accessed")
52 (fill-gaps-only-p :accessor fill-gaps-only-p
53 :initarg :fill-gaps-only-p
54 :initform nil
55 :documentation
56 "When nil, the instance is syncronised with the database.
57 When T, only the default value for primary keys and the joins are updated.")
58 (show-label-p :accessor show-label-p :initarg :show-label-p :initform t)
59 (creatablep :accessor creatablep :initarg :creatablep :initform t))
60 (:documentation "The superclass of all Mewa slot presentations"))
61
62 ;;;; this has to be in the eval when i would think
63 (eval-when (:compile-toplevel :load-toplevel :execute)
64 (defun generate-slot-presentation-definition-for-type (type)
65 (let* ((u-name (intern (format nil "~A-SLOT-PRESENTATION" type)))
66 (sp-name (intern (format nil "MEWA-~A" u-name)))
67 (t-name (intern (format nil "MEWA-~A" type))))
68 `(defslot-presentation ,sp-name (,u-name mewa-slot-presentation)
69 ()
70 (:type-name ,t-name)))))
71
72 (defmacro define-base-mewa-presentations (&body types)
73 "Define the mewa-slot-presentations by subclassing the base UCW ones"
74 `(progn ,@(mapcar #'generate-slot-presentation-definition-for-type
75 types)))
76
77 ;;;then actually define the base presentations :
78 (define-base-mewa-presentations
79 boolean
80 string
81 number
82 integer
83 currency)
84
85 (defslot-presentation clsql-wall-time-slot-presentation (mewa-relation-slot-presentation)
86 ((input-id :accessor input-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
87 (trigger-id :accessor trigger-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
88 (default-to-now-p :accessor default-to-now-p :initarg :default-to-now-p :initform nil))
89 (:type-name clsql-sys:wall-time))
90
91 (defmethod presentation-slot-value ((slot clsql-wall-time-slot-presentation) instance)
92 (let ((date (call-next-method)))
93 (when date (multiple-value-bind (y m d) (clsql:time-ymd date)
94 (format nil "~a/~a/~a" m d y)))))
95
96 (defmethod (setf presentation-slot-value) ((value string) (slot clsql-wall-time-slot-presentation) instance)
97 (let ((new-time (clsql:parse-date-time (remove #\Space value)))
98 (old-time (when (slot-boundp instance (slot-name slot))
99 (slot-value instance (slot-name slot)))))
100 (unless (or (eql old-time new-time)
101 (when (and new-time old-time)
102 (equal :equal (clsql:time-compare new-time old-time))))
103 (setf (presentation-slot-value slot instance) new-time))))
104
105 (defmethod label :around ((slot clsql-wall-time-slot-presentation))
106 (concatenate 'string (call-next-method) " (m/d/y)"))
107
108 (defmethod present-slot ((slot clsql-wall-time-slot-presentation) instance)
109 (let ((date (presentation-slot-value slot instance)))
110 ;; Default values
111 (when (and (not date) (default-to-now-p slot))
112 (setf (presentation-slot-value slot instance) (clsql:get-time)))
113 ;;simple viewer
114 (if (and date (not (editablep slot)))
115 (<:as-html date))
116 ;; editor
117 (when (editablep slot)
118 (<ucw:input :accessor (presentation-slot-value slot instance) :id (input-id slot) :style "display:inline")
119 (<:button :id (trigger-id slot) (<:as-html "[...]"))
120 (<:script :type "text/javascript"
121 (<:as-is (format nil "
122
123 Calendar.setup({
124 inputField : \"~a\",
125 button : \"~a\",
126 ifFormat : \"%m/%d/%Y\" });" (input-id slot) (trigger-id slot)))))))
127
128 (defslot-presentation mewa-relation-slot-presentation (mewa-slot-presentation slot-presentation)
129 ((foreign-instance :accessor foreign-instance)
130 (linkedp :accessor linkedp :initarg :linkedp :initform t)
131 (creator :accessor creator :initarg :creator :initform :editor)
132 (new-instance :accessor new-instance :initform nil))
133 (:type-name relation))
134
135 (defaction search-records ((slot mewa-relation-slot-presentation) instance)
136 (multiple-value-bindf (finstance foreign-slot-name)
137 (meta-model:explode-foreign-key instance (slot-name slot))
138 (let ((new-instance (new-instance self)))
139 (unless new-instance
140 (setf (new-instance self)
141 (call-component
142 (ucw::parent slot)
143 (make-instance (or (cadr (mewa:find-attribute finstance :presentation-search))
144 'mewa::mewa-presentation-search)
145 :search-presentation
146 (mewa:make-presentation finstance
147 :type :search-presentation)
148 :list-presentation
149 (mewa:make-presentation finstance
150 :type :listing)))))
151 (sync-foreign-instance slot new-instance))))
152
153 (defmethod sync-foreign-instance ((slot mewa-relation-slot-presentation) foreign-instance)
154 (let ((instance (instance (ucw::parent slot))))
155 (multiple-value-bind (foo f-slot-name)
156 (meta-model:explode-foreign-key instance (slot-name slot))
157 (setf (slot-value instance (slot-name slot)) (slot-value foreign-instance f-slot-name))
158 (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p slot)))))
159
160
161 (defaction create-record-on-foreign-key ((slot mewa-relation-slot-presentation) instance)
162 (multiple-value-bindf (finstance foreign-slot-name)
163 (meta-model:explode-foreign-key instance (slot-name slot))
164 (let ((new-instance
165 (call-component
166 (ucw::parent slot)
167 (mewa:make-presentation finstance :type (creator self)))))
168
169 ;;;; TODO: this next bit is due to a bad design decision.
170 ;;;; Components should always have (ok) return self, but somewhere
171 ;;;; i've made in return (instance self) sometimes, and this
172 ;;;; bahaviour is totatlly fucked.
173
174 (when (typep new-instance 'mewa::mewa)
175 (setf new-instance (instance new-instance)))
176
177 ;;;; sorry about that, and now back t our regular program.
178
179 (meta-model:sync-instance new-instance)
180 (setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name))
181 (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p self)))))
182
183
184 (defmethod present-relation ((slot mewa-relation-slot-presentation) instance)
185 ;;;;(<:as-html (slot-name slot) "=> " (foreign-instance slot) " from " instance )
186 (let* ((i (foreign-instance slot))
187 (pres (mewa::make-presentation
188 i
189 :type :one-line
190 :initargs (list
191 :global-properties
192 (list :editablep nil :linkedp nil)))))
193 (when (and (ucw::parent slot) (slot-boundp slot 'ucw::place))
194 (setf (component.place pres) (component.place (ucw::parent slot))))
195 (when i (<ucw:render-component :component pres))))
196
197 (defmethod present-slot ((slot mewa-relation-slot-presentation) instance)
198 (present-relation slot instance))
199
200 (defslot-presentation foreign-key-slot-presentation (mewa-relation-slot-presentation)
201 ()
202 (:type-name foreign-key)
203 (:default-initargs))
204
205 (defaction view-instance ((self component) instance &rest initargs)
206 (call-component (ucw::parent self) (apply #'mewa:make-presentation instance initargs))
207 ;; the viewed instance could have been changed/deleted, so we sync this instance
208 (meta-model:sync-instance (instance (ucw::parent self))))
209
210
211 (defmethod present-slot :around ((slot foreign-key-slot-presentation) instance)
212 (setf (foreign-instance slot)
213 (when (presentation-slot-value slot instance)
214 (meta-model:explode-foreign-key instance (slot-name slot))))
215 (flet ((render () (when (foreign-instance slot)(call-next-method))))
216 (if (slot-boundp slot 'ucw::place)
217 (cond
218 ((editablep slot)
219 (render)
220 (<ucw:submit :action (search-records slot instance) :value "Search" :style "display:inline")
221 (<ucw:submit :action (create-record-on-foreign-key slot instance) :value "Add New" :style "display:inline"))
222 ((linkedp slot)
223 (<ucw:a :action (view-instance slot (foreign-instance slot))
224 (render)))
225 (t
226 (render)))
227 ;; presentation is used only for rendering
228 (render))))
229
230
231 (defmethod find-foreign-instances ((slot foreign-key-slot-presentation))
232 (clsql:select (class-name (class-of (meta-model:explode-foreign-key (instance slot) (slot-name slot))))))
233
234
235
236 ;;;; HAS MANY
237 (defslot-presentation has-many-slot-presentation (mewa-relation-slot-presentation)
238 ((add-new-label :accessor add-new-label :initarg :add-new-label :initform "Add New"))
239 (:type-name has-many))
240
241 (defaction add-to-has-many ((slot has-many-slot-presentation) instance)
242 ;; if the instance is not stored we must make sure to mark it stored now!
243 (unless (meta-model::persistentp instance)
244 (setf (mewa::modifiedp (ucw::parent self)) t))
245 ;; sync up the instance
246 ;;(mewa:ensure-instance-sync (parent slot))
247 (meta-model:sync-instance (instance (ucw::parent slot)))
248
249 (multiple-value-bindf (class home foreign)
250 (meta-model:explode-has-many instance (slot-name slot))
251 (let ((new (make-instance class)))
252 (setf (slot-value new foreign) (slot-value instance home))
253 (meta-model:sync-instance new :fill-gaps-only-p (fill-gaps-only-p self))
254 (call-component (ucw::parent slot) (mewa:make-presentation new :type (creator slot)))
255 (meta-model:sync-instance instance))))
256
257 (defmethod present-slot ((slot has-many-slot-presentation) instance)
258 (when (slot-boundp slot 'ucw::place)
259 (<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label slot)))
260 (let* ((i (get-foreign-instances slot instance))
261 (presentation (and i (make-presentation (car i) :type :one-line))))
262 (when i
263 (flet ((linker (i string)
264 (<ucw:a
265 :action (view-instance slot i
266 :initargs
267 `(:global-properties ,
268 (list
269 :linkedp t
270 :editablep nil)))
271 (<:as-html string))))
272 (<:table :cellpadding 10
273 (<:tr
274 (<:th) ;empty col for (view) link
275 (dolist (s (slots presentation))
276 (<:th (<:as-html (label s)))))
277 (dolist (s i)
278 (let ((s s))
279 (setf (foreign-instance slot) s)
280 (when (slot-boundp slot 'ucw::place)
281 (<:tr
282 (<:td (linker s " (view) "))
283 (dolist (p (slots (make-presentation s :type :one-line
284 :initargs
285 '(:global-properties
286 (:editablep nil)))))
287 (<:td
288
289 (present-slot p s))))))))))))
290
291
292 (defmethod get-foreign-instances ((slot has-many-slot-presentation) instance)
293 (slot-value instance (slot-name slot)))
294
295 (defmethod presentation-slot-value ((slot has-many-slot-presentation) instance)
296 (get-foreign-instances slot instance))
297
298 (defslot-presentation has-very-many-slot-presentation (has-many-slot-presentation)
299 ((number-to-display :accessor number-to-display :initarg :number-to-display :initform 10)
300 (current :accessor current :initform 0)
301 (len :accessor len )
302 (instances :accessor instances))
303 (:type-name has-very-many))
304
305 (defmethod list-next ((slot has-very-many-slot-presentation))
306 (setf (current slot) (incf (current slot) (number-to-display slot)))
307 (when (< (len slot) (current slot))
308 (setf (current slot) (- (number-to-display slot) (len slot)))))
309
310 (defmethod list-prev ((slot has-very-many-slot-presentation))
311 (setf (current slot) (decf (current slot) (number-to-display slot)))
312 (when (> 0 (current slot))
313 ;;what to do here is open to debate
314 (setf (current slot) (- (len slot)(number-to-display slot) ))))
315
316
317 (defmethod present-slot ((slot has-very-many-slot-presentation) instance)
318 ;;(<:as-html "isance: " instance)
319 (if (slot-boundp slot 'ucw::place)
320 (progn
321 (<ucw:a :action (list-prev slot) (<:as-html "<<"))
322 (let ((self (ucw::parent slot)))
323 (<ucw:a :action (call-component self (mewa:make-presentation (car (slot-value instance (slot-name slot))) :type :listing :initargs (list :instances (instances slot))))
324 (<:as-html (label slot) (format nil " ~a-~a " (current slot) (+ (current slot) (number-to-display slot))))))
325 (<ucw:a :action (list-next slot) (<:as-html ">>"))
326 (call-next-method)
327 (<:as-html "total :" (len slot)))
328 (call-next-method)))
329
330 (defmethod get-foreign-instances :around ((slot has-very-many-slot-presentation) instance)
331 (let ((f (call-next-method)))
332 (setf (len slot) (length f))
333 (setf (instances slot) f)
334 (loop for cons on (nthcdr (current slot) f)
335 for i from 0 upto (number-to-display slot)
336 collect (car cons))))
337
338
339 ;;;; * Has-a
340 (defslot-presentation has-a-slot-presentation (mewa-relation-slot-presentation)
341 ((allow-nil-p :accessor allow-nil-p :initarg :allow-nil-p :initform t)
342 (attributes :accessor attributes :initarg :attributes :initform nil))
343 (:type-name has-a))
344
345 (defmethod find-foreign-slot-value ((slot has-a-slot-presentation) (object t))
346 (multiple-value-bind (c s)
347 (meta-model:explode-foreign-key (instance (ucw::parent slot)) (slot-name slot))
348 (slot-value object s)))
349
350 (defmethod get-foreign-instances ((slot mewa-relation-slot-presentation) instance)
351 (clsql:select (class-name (class-of
352 (meta-model:explode-foreign-key instance (slot-name slot))))
353 :flatp t))
354
355 (defmethod present-slot ((slot has-a-slot-presentation) instance)
356 ; (<:as-html (presentation-slot-value slot instance))
357 (if (editablep slot)
358 (progn (<ucw:select :accessor (presentation-slot-value slot instance) :test #'equalp
359 (when (allow-nil-p slot)
360 (<ucw:option :value nil (<:as-html "none")))
361 (dolist (option (get-foreign-instances slot instance))
362 (<ucw:option :value (find-foreign-slot-value slot option)
363 (lol:present
364 (lol:make-presentation option
365 :type :as-string
366 :initargs
367 `(:attributes ,(attributes slot)))
368 ))))
369 (when (creatablep slot)
370 (<ucw:submit :action (create-record-on-foreign-key slot instance) :value "Add New" :style "display:inline")))
371 (if (presentation-slot-value slot instance)
372 (progn
373 (lol:present
374 (lol:make-presentation (meta-model:explode-foreign-key instance (slot-name slot))
375 :type :one-line
376 :initargs
377 `(:attributes ,(attributes slot)))
378 ))
379 (<:as-html "--"))))
380
381 (defslot-presentation many-to-many-slot-presentation (mewa-relation-slot-presentation)
382 ((list-view :accessor list-view :initarg :list-view :initform :one-line)
383 (action-view :accessor action-view :initarg :action-view :initform :viewer)
384 (create-view :initform :creator)
385 (select-view :initform :as-string :accessor select-view))
386 (:type-name many-to-many)
387 (:default-initargs :label "many to many"))
388
389 (defun %delete-item (item)
390 (clsql:with-default-database (clsql:*default-database*)
391 (ignore-errors
392 (clsql:delete-instance-records item))))
393
394 (defaction delete-item ((self component) instance)
395 (multiple-value-bind (res err) (%delete-item instance)
396 (if (not err)
397 (call 'info-message :message "Removed Instance")
398 (call 'info-message :message (format nil "Could not remove item. Try removing associated items first. ~A" instance)))))
399
400 (defaction delete-relationship ((slot many-to-many-slot-presentation) rel instance)
401 (delete-item (ucw::parent self) rel)
402 (sync-instance instance)
403 (answer-component (ucw::parent self) t))
404
405
406 (defun find-many-to-many-join-class (slot instance)
407 (let* ((imd (getf (meta-model::find-slot-metadata instance (slot-name slot))
408 :db-info))
409 (jc (make-instance (getf imd :join-class)))
410 (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
411 :db-info)))
412 (getf jcmd :join-class)))
413
414 (defmethod find-all-instances ((slot many-to-many-slot-presentation) instance)
415 (clsql:select (find-many-to-many-join-class slot instance) :flatp t))
416
417 (defmethod present-slot ((slot many-to-many-slot-presentation) instance)
418 (let ((instances (slot-value instance (slot-name slot)))
419 new-instance)
420 (<:ul
421 (<:li (<ucw:button :action (add-to-many-to-many slot instance)
422 (<:as-html "Add New")))
423 (<:li (<ucw:button :action (add-to-many-to-many slot instance new-instance)
424 (<:as-html "Add:"))
425 (<ucw:select :accessor new-instance
426 (arnesi:dolist* (i (find-all-instances slot instance))
427 (<ucw:option
428 :value i
429 (lol:present-view (i (select-view slot) slot))))))
430 (dolist* (i instances)
431 (<:li
432 (<ucw:a :action (call-view ((car i) (action-view slot) (ucw::parent slot)))
433 (<:as-html "(view) "))
434 (<ucw:a :action (delete-relationship slot (second i) instance)
435 (<:as-html "(remove) "))
436 (present-view ((car i) (list-view slot) (ucw::parent slot)))) ))))
437
438
439 (defaction add-to-many-to-many ((slot many-to-many-slot-presentation) instance &optional foreign-instance)
440 ;;;; First things first, we sync.
441 (sync-instance instance)
442 (let* (new
443 (imd (getf (meta-model::find-slot-metadata instance (slot-name slot))
444 :db-info))
445 (jc (make-instance (getf imd :join-class)))
446 (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
447 :db-info))
448 (fc (make-instance (getf jcmd :join-class)))
449 (c (if
450 foreign-instance
451 foreign-instance
452 (call-view (fc :creator (ucw::parent slot))))))
453 (when c
454 (sync-instance c)
455 ; (error "~A ~A ~A" (getf imd :foreign-key) (getf jcmd :foreign-key) (getf imd :home-key))
456 (setf (slot-value jc (getf imd :foreign-key))
457 (slot-value instance (getf imd :home-key)))
458 (setf (slot-value jc (getf jcmd :home-key))
459 (slot-value c (getf jcmd :foreign-key)))
460 (sync-instance jc)
461
462 (sync-instance instance)
463 c)))