| 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 :accessor render :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 | (defaction call-auto-complete ((self t) auto-complete-id value index) |
| 75 | (let ((auto-complete (get-session-value (intern auto-complete-id)))) |
| 76 | (if auto-complete |
| 77 | (if index |
| 78 | (select-value auto-complete index) |
| 79 | (call-auto-complete-from-output auto-complete auto-complete-id value self)) |
| 80 | (call 'empty-page :message (error "Cannot find"))))) |
| 81 | |
| 82 | (defaction call-auto-complete-from-output ((auto-complete auto-complete) auto-complete-id value output) |
| 83 | (setf (client-value auto-complete) value) |
| 84 | (let ((self output)) |
| 85 | (call (output-component-name auto-complete) :auto-complete auto-complete) |
| 86 | (call 'empty-page :message (error "ASD")))) |
| 87 | |
| 88 | (defaction select-value ((self auto-complete) index) |
| 89 | (let ((index (when (< 0 (length index)) |
| 90 | (parse-integer index)))) |
| 91 | (setf (index self) index) |
| 92 | (setf (value self) (nth index (list-of-values self))))) |
| 93 | |
| 94 | (defun make-auto-complete-url (input-id) |
| 95 | "creates a url that calls the auto-complete entry-point for INPUT-ID." |
| 96 | (format nil "auto-complete.ucw?&auto-complete-id=~A&~A=~A" |
| 97 | input-id ucw::+session-parameter-name+ |
| 98 | (ucw::session.id (ucw::context.session ucw::*context*)))) |
| 99 | |
| 100 | (defaction on-submit ((l auto-complete)) |
| 101 | ()) |
| 102 | |
| 103 | (defmethod js-on-select ((l auto-complete)) |
| 104 | "the javascript that is called when an item is selected" |
| 105 | (when (submit-on-select-p l) |
| 106 | `(progn |
| 107 | (set-action-parameter ,(register-action |
| 108 | (lambda () |
| 109 | (arnesi:with-call/cc |
| 110 | (on-submit l))))) |
| 111 | (submit-form)))) |
| 112 | |
| 113 | |
| 114 | (defmethod render-on ((res response) (l auto-complete)) |
| 115 | ;; session-values are stored in an eql hash table. |
| 116 | (let ((input-key (intern (input-id l)))) |
| 117 | ;; We are storing the input components in the session, |
| 118 | ;; keyed on the string that we also use as the id for |
| 119 | ;; the input field. |
| 120 | |
| 121 | (unless (get-session-value input-key) |
| 122 | (setf (get-session-value input-key) l)) |
| 123 | |
| 124 | ;; A hidden field to hold the index number selected via javascript |
| 125 | (<ucw:text :accessor (client-value l) |
| 126 | :id (input-id l) :size (input-size l)) |
| 127 | (<:div :id (output-id l) :class "auto-complete" (<:as-html " "))) |
| 128 | (let* ((a (make-symbol (format nil "~A-autocompleter" (input-id l)))) |
| 129 | (f (make-symbol (format nil "~A.select-entry-function"a)))) |
| 130 | (<ucw:script |
| 131 | `(setf ,a |
| 132 | (new |
| 133 | (*Ajax.*Autocompleter |
| 134 | ,(input-id l) ,(output-id l) |
| 135 | ,(make-auto-complete-url (input-id l)) |
| 136 | (create |
| 137 | :param-name "value")))) |
| 138 | `(setf ,f (slot-value ,a 'select-entry)) |
| 139 | `(setf (slot-value ,a 'select-entry) |
| 140 | (lambda () |
| 141 | (,f) |
| 142 | ,(generate-ajax-request |
| 143 | (make-auto-complete-url (input-id l)) |
| 144 | `(create |
| 145 | :parameters (+ "&index=" (slot-value ,a 'index)) |
| 146 | :method "post" |
| 147 | :on-complete (lambda (res) |
| 148 | ,(js-on-select l))))))))) |
| 149 | |
| 150 | |
| 151 | ;;;; * auto-complete-ouput |
| 152 | |
| 153 | |
| 154 | (defcomponent auto-complete-output (window-component) |
| 155 | ((auto-complete :initarg :auto-complete :accessor auto-complete))) |
| 156 | |
| 157 | (defmethod render-on ((res response) (output auto-complete-output)) |
| 158 | (let ((auto-complete (auto-complete output))) |
| 159 | (setf (list-of-values auto-complete) |
| 160 | (funcall (values-generator auto-complete) (client-value auto-complete))) |
| 161 | (<:ul |
| 162 | :class "auto-complete-list" |
| 163 | (arnesi:dolist* (value (list-of-values auto-complete)) |
| 164 | (<:li |
| 165 | :class "auto-complete-list-item" |
| 166 | (funcall (render auto-complete) value)))))) |
| 167 | |
| 168 | (defcomponent fkey-auto-complete (auto-complete) |
| 169 | ()) |
| 170 | |
| 171 | (defmethod js-on-select ((self fkey-auto-complete)) |
| 172 | (with-ajax-action (self) |
| 173 | (mewa::sync-foreign-instance (ucw::parent self) (value self)))) |
| 174 | |
| 175 | (defslot-presentation ajax-foreign-key-slot-presentation (mewa::foreign-key-slot-presentation) |
| 176 | ((original-value :accessor original-value :initform nil) |
| 177 | (search-slots :accessor search-slots :initarg :search-slots :initform nil) |
| 178 | (live-search |
| 179 | :accessor live-search |
| 180 | :component fkey-auto-complete)) |
| 181 | (:type-name ajax-foreign-key)) |
| 182 | |
| 183 | |
| 184 | (defmethod shared-initialize :after ((slot ajax-foreign-key-slot-presentation) slots &rest args) |
| 185 | (let* ((l (live-search slot)) |
| 186 | (slot-name (slot-name slot)) |
| 187 | (instance (instance (ucw::parent slot))) |
| 188 | (foreign-instance (explode-foreign-key instance slot-name)) |
| 189 | (class-name (class-name |
| 190 | (class-of foreign-instance)))) |
| 191 | ;; If no search-slots than use the any slots of type string |
| 192 | (unless (search-slots slot) |
| 193 | (setf (search-slots slot) (find-slots-of-type foreign-instance))) |
| 194 | |
| 195 | (setf (lisp-on-lines::values-generator l) |
| 196 | (lambda (input) |
| 197 | (word-search class-name |
| 198 | (search-slots slot) input))) |
| 199 | |
| 200 | (setf (lisp-on-lines::render l) |
| 201 | (lambda (val) |
| 202 | (<ucw:render-component |
| 203 | :component (make-presentation val :type :one-line)))))) |
| 204 | |
| 205 | (defaction revert-foreign-slot ((slot ajax-foreign-key-slot-presentation)) |
| 206 | (setf (lol::value (live-search slot)) nil) |
| 207 | (when (original-value slot) |
| 208 | (mewa::sync-foreign-instance slot (original-value slot)))) |
| 209 | |
| 210 | (defmethod present-slot :around ((slot ajax-foreign-key-slot-presentation) instance) |
| 211 | |
| 212 | (let ((foreign-instance |
| 213 | (if (lol::value (live-search slot)) |
| 214 | (lol::value (live-search slot)) |
| 215 | (setf (original-value slot) |
| 216 | (when (presentation-slot-value slot instance) |
| 217 | (meta-model:explode-foreign-key instance (slot-name slot))))))) |
| 218 | |
| 219 | (flet ((render () (when foreign-instance (call-next-method)))) |
| 220 | (if (slot-boundp slot 'ucw::place) |
| 221 | (cond |
| 222 | ((editablep slot) |
| 223 | (when foreign-instance |
| 224 | (setf (client-value (live-search slot)) |
| 225 | (with-output-to-string (s) |
| 226 | (yaclml:with-yaclml-stream s |
| 227 | (present (make-presentation foreign-instance |
| 228 | :type :one-line)))))) |
| 229 | |
| 230 | (<ucw:render-component :component (live-search slot)) |
| 231 | (<ucw:submit :action (revert-foreign-slot slot) |
| 232 | :value "Undo") |
| 233 | (<ucw:submit :action (mewa::search-records slot instance) :value "find" :style "display:inline")) |
| 234 | ((mewa::linkedp slot) |
| 235 | (<ucw:a :action (mewa::view-instance slot foreign-instance) |
| 236 | (render))) |
| 237 | (t |
| 238 | (render))) |
| 239 | ;; presentation is used only for rendering |
| 240 | (render))))) |