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