Major patch touching a lot, representing the new lol. is mostly drop-in backwards...
[clinton/lisp-on-lines.git] / src / components / ajax.lisp
1 (in-package :lisp-on-lines)
2
3 ;;;; for when there is nothing left to display.
4 (defcomponent empty-page (window-component)
5 ())
6
7 (defmethod render-on ((res response) (self empty-page))
8 "didnt find a thing")
9
10 (defcomponent auto-complete ()
11 ((input-id :accessor input-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
12 (output-id :accessor output-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
13 (client-value
14 :accessor client-value
15 :initform ""
16 :documentation "The string the user has, so far, insterted.")
17 (index
18 :accessor index
19 :initform nil
20 :documentation "The index (for use with NTH) in list-of-values of the item selected via Ajax")
21 (list-of-values
22 :accessor list-of-values
23 :initform '()
24 :documentation "The list generated by values-generator")
25 (values-generator :accessor values-generator :initarg :values-generator
26 :documentation "Function which, when passed the auto-complete component, returns a list of objects.")
27 (value
28 :accessor value
29 :initform nil
30 :documentation "The lisp value of the object selecting in the drop down")
31 (as-value :accessor as-value :initarg :as-value
32 :documentation "Function which, when passed a value, returns the string to put in the text box.")
33 (render-it :accessor render-it :initarg :render
34 :documentation "Function which, when passed the component and one of the values render it (the value).")
35 (input-size :accessor input-size :initarg :input-size :initform 20)
36 (submit-on-select-p
37 :accessor submit-on-select-p
38 :initarg :submit-on-select-p
39 :initform t)
40 (output-component-name :accessor output-component-name :initarg :output-comonent-name :initform 'auto-complete-output)))
41
42 (defmethod js-on-complete ((l auto-complete))
43 `(lambda (transport)
44 (setf (slot-value (document.get-element-by-id ,(output-id l))
45 'inner-h-t-m-l)
46 transport.response-text)))
47
48 (defmacro make-action-url (component action)
49 "
50 There has got to be something like this buried in UCW somewhere,
51 but here's what i use."
52 `(ucw::print-uri-to-string
53 (compute-url ,component
54 :action-id (ucw::make-new-action (ucw::context.current-frame *context*)
55 (lambda ()
56 (arnesi:with-call/cc
57 ,action))))))
58
59 (defun generate-ajax-request (js-url &optional js-options)
60 `(new
61 (*Ajax.*Request
62 ,js-url
63 ,js-options)))
64
65 (defmacro with-ajax-request (js-url &rest js-options)
66 `(generate-ajax-request-for-url
67 ,js-url
68 ,@js-options))
69
70 (defmacro with-ajax-action ((component) &body action)
71 `(generate-ajax-request
72 (make-action-url ,component (progn ,@action))))
73
74
75 (defun make-auto-complete-url (input-id)
76 "creates a url that calls the auto-complete entry-point for INPUT-ID."
77 (format nil "auto-complete.ucw?&auto-complete-id=~A&~A=~A"
78 input-id "session"
79 (ucw::session.id (ucw::context.session ucw::*context*))))
80
81 (defaction on-submit ((l auto-complete))
82 ())
83
84 (defmethod js-on-select ((l auto-complete))
85 "the javascript that is called when an item is selected"
86 (when (submit-on-select-p l)
87 `(progn
88 (set-action-parameter ,(register-action
89 (lambda ()
90 (arnesi:with-call/cc
91 (on-submit l)))))
92 (submit-form))))
93
94
95 (defmethod render ( (l auto-complete))
96 ;; session-values are stored in an eql hash table.
97 (let ((input-key (intern (input-id l))))
98 ;; We are storing the input components in the session,
99 ;; keyed on the string that we also use as the id for
100 ;; the input field.
101
102 (unless (get-session-value input-key)
103 (setf (get-session-value input-key) l))
104
105 ;; A hidden field to hold the index number selected via javascript
106 (<ucw:text :accessor (client-value l)
107 :id (input-id l) :size (input-size l))
108 (<:div :id (output-id l) :class "auto-complete" (<:as-html " ")))
109 (let* ((a (make-symbol (format nil "~A-autocompleter" (input-id l))))
110 (f (make-symbol (format nil "~A.select-entry-function"a))))
111 (<ucw:script
112 `(setf ,a
113 (new
114 (*Ajax.*Autocompleter
115 ,(input-id l) ,(output-id l)
116 ,(make-auto-complete-url (input-id l))
117 (create
118 :param-name "value"))))
119 `(setf ,f (slot-value ,a 'select-entry))
120 `(setf (slot-value ,a 'select-entry)
121 (lambda ()
122 (,f)
123 ,(generate-ajax-request
124 (make-auto-complete-url (input-id l))
125 `(create
126 :parameters (+ "&index=" (slot-value ,a 'index))
127 :method "post"
128 :on-complete (lambda (res)
129 ,(js-on-select l)))))))))
130
131
132 ;;;; * auto-complete-ouput
133
134
135 (defcomponent auto-complete-output (window-component)
136 ((auto-complete :initarg :auto-complete :accessor auto-complete)))
137
138 (defmethod render ((output auto-complete-output))
139 (let ((auto-complete (auto-complete output)))
140 (setf (list-of-values auto-complete)
141 (funcall (values-generator auto-complete) (client-value auto-complete)))
142 (<:ul
143 :class "auto-complete-list"
144 (arnesi:dolist* (value (list-of-values auto-complete))
145 (<:li
146 :class "auto-complete-list-item"
147 (funcall (render-it auto-complete) value))))
148 (answer-component output t)))
149
150 (defcomponent fkey-auto-complete (auto-complete)
151 ())
152
153 (defmethod js-on-select ((self fkey-auto-complete))
154 (with-ajax-action (self)
155 (mewa::sync-foreign-instance (ucw::parent self) (value self))))
156
157 (defslot-presentation ajax-foreign-key-slot-presentation (mewa::foreign-key-slot-presentation)
158 ((original-value :accessor original-value :initform nil)
159 (search-slots :accessor search-slots :initarg :search-slots :initform nil)
160 (live-search
161 :accessor live-search
162 :component fkey-auto-complete))
163 (:type-name ajax-foreign-key))
164
165
166 (defmethod shared-initialize :after ((slot ajax-foreign-key-slot-presentation) slots &rest args)
167 (let* ((l (live-search slot))
168 (slot-name (slot-name slot))
169 (instance (instance (ucw::parent slot)))
170 (foreign-instance (explode-foreign-key instance slot-name))
171 (class-name (class-name
172 (class-of foreign-instance))))
173 ;; If no search-slots than use the any slots of type string
174 (unless (search-slots slot)
175 (setf (search-slots slot) (find-slots-of-type foreign-instance)))
176
177 (setf (lisp-on-lines::values-generator l)
178 (lambda (input)
179 (word-search class-name
180 (search-slots slot) input)))
181
182 (setf (lisp-on-lines::render-it l)
183 (lambda (val)
184 (<ucw:render-component
185 :component (make-presentation val :type :one-line))))))
186
187 (defaction revert-foreign-slot ((slot ajax-foreign-key-slot-presentation))
188 (setf (lol::value (live-search slot)) nil)
189 (when (original-value slot)
190 (mewa::sync-foreign-instance slot (original-value slot))))
191
192 (defmethod present-slot :around ((slot ajax-foreign-key-slot-presentation) instance)
193
194 (let ((foreign-instance
195 (if (lol::value (live-search slot))
196 (lol::value (live-search slot))
197 (setf (original-value slot)
198 (when (presentation-slot-value slot instance)
199 (meta-model:explode-foreign-key instance (slot-name slot)))))))
200
201 (flet ((render-s () (when foreign-instance (call-next-method))))
202
203 (if (slot-boundp slot 'ucw::place)
204 (cond
205 ((editablep slot)
206 (when foreign-instance
207 (setf (client-value (live-search slot))
208 (with-output-to-string (s)
209 (yaclml:with-yaclml-stream s
210 (present (make-presentation foreign-instance
211 :type :one-line))))))
212
213 (<ucw:render-component :component (live-search slot))
214 #+ (or) (<ucw:submit :action (revert-foreign-slot slot)
215 :value "Undo")
216 #+ (or) (<ucw:submit :action (mewa::search-records slot instance) :value "find" :style "display:inline"))
217 ((mewa::linkedp slot)
218 (<ucw:a :action (mewa::view-instance slot foreign-instance)
219 (render-s)))
220 (t
221 (render-s)))
222 ;; presentation is used only for rendering
223 (render-s))))
224 )