/src/autocomplete.lisp

  1(in-package :wu)
  2
  3;;; +=========================================================================+
  4;;; | Copyright (c) 2009, 2010  Mike Travers and CollabRx, Inc                |
  5;;; |                                                                         |
  6;;; | Released under the MIT Open Source License                              |
  7;;; |   http://www.opensource.org/licenses/mit-license.php                    |
  8;;; |                                                                         |
  9;;; | Permission is hereby granted, free of charge, to any person obtaining   |
 10;;; | a copy of this software and associated documentation files (the         |
 11;;; | "Software"), to deal in the Software without restriction, including     |
 12;;; | without limitation the rights to use, copy, modify, merge, publish,     |
 13;;; | distribute, sublicense, and/or sell copies of the Software, and to      |
 14;;; | permit persons to whom the Software is furnished to do so, subject to   |
 15;;; | the following conditions:                                               |
 16;;; |                                                                         |
 17;;; | The above copyright notice and this permission notice shall be included |
 18;;; | in all copies or substantial portions of the Software.                  |
 19;;; |                                                                         |
 20;;; | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,         |
 21;;; | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF      |
 22;;; | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  |
 23;;; | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY    |
 24;;; | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,    |
 25;;; | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE       |
 26;;; | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.                  |
 27;;; +=========================================================================+
 28
 29;;; Author:  Mike Travers
 30
 31
 32(export '(auto-complete-field 
 33	  auto-complete-field-sparql
 34	  in-place-field in-place-setf-field))
 35
 36#|
 37Support for autocomplete and in-place-editor widgets
 38
 39See http://madrobby.github.com/scriptaculous/ajax-autocompleter/
 40
 41Requires a DOM element named "body" to control where the autocomplete box gets inserted.
 42
 43 Todo: 
 44 - layout and bounds stuff.
 45 - idea: a greyed out type indicator by default (apparently not supported by scriptaculous -- but it ought to layer on top OK).
 46 - completion machinery for replacing box with frame on comp
 47     updateElement     
 48 - highlighting match (esp for :match-type :word)
 49 - style stuff should be pulled out
 50
 51|#
 52
 53(defun auto-complete-field (&key (id (string (gensym "id")))
 54			    name
 55			    value
 56			    options
 57			    completions-url
 58			    completions-generator
 59			    embedded-html
 60			    on-selected
 61			    textarea
 62			    (update (string+ id "_auto_complete"))
 63			    input-options
 64			    (scroll? 30)
 65			    spinner?
 66			    )
 67  #.(doc "Generate an HTML autocompletion field. Arguments below (all except completions-url are optional)"
 68	 "ID - the HTML ID of the element"
 69	 "NAME - the name of the field"
 70	 "VALUE - the current value of the field"
 71	 "TEXTAREA - T to use a multi-line textarea"
 72	 "OPTIONS - additional options to pass to the scriptaculous Ajax.Autocompleter object."
 73	 "INPUT-OPTIONS - options to pass to the input or textarea tag (eg '((\"tokens\" . (\",\" #\Newline))))"
 74	 "COMPLETIONS-GENERATOR - a procedure that takes a prefix and returns a list of (id . name) pairs"
 75	 "EMBEDDED-HTML - T if strings can contain HTML markup"
 76	 "COMPLETIONS-URL - a URL that supplies the completions.  Either this or COMPLETIONS-GENERATOR must be supplied, but not both"
 77	 "ON-SELECTED - a function that is called with the value, value string, and id of the selected option"
 78	 "UPDATE - the HTML ID of the autocompletion box"
 79	 "SCROLL? - If an integer, add scroll bar if more completions than this (default to 30)"
 80	 "SPINNER? - T to show a spinner while fetching completions")
 81  (flet ((default-option (optname value)
 82	   (unless (member optname options :key #'car :test #'equal)
 83	     (push (cons optname value) options))))
 84    (default-option "paramName" "prefix")
 85    (when on-selected
 86      (default-option "afterUpdateElement" 
 87	  `(:raw "postAutocomplete")))
 88    (when spinner?
 89      (default-option "indicator" (string+ id "_spin"))))
 90  (unless completions-url
 91    (assert completions-generator)
 92    (setq completions-url
 93	  (ajax-continuation (:args (prefix) :keep t :name "ac_completions") 
 94	    (let ((completions (funcall completions-generator prefix)))
 95	      (html
 96	       ((:ul :if* (> (length completions) scroll?) :style "height:500px;overflow:scroll;")
 97		(dolist (completion completions)
 98		  (html
 99		   ((:li :id (car completion))
100		    (if embedded-html
101			(html (:princ (cdr completion)))
102			(html (:princ-safe (cdr completion)))))))))))))
103  (if textarea
104      (html ((:textarea :id id :name name :do* input-options) 
105	     (if value (html (:princ-safe value)))))
106      (html ((:input :id id :name name :if* value :value value :do* input-options))))
107  (if spinner?
108      (html 
109       ((:img :src "/wupub/images/spinner.gif" :id (string+ id "_spin") :style "display:none;"))))
110  (render-scripts
111    ;; put the autocomplete div somewhere where it won't get clipped
112    (:insert :bottom "body"		
113	     (html ((:div :id update :class "auto_complete"))))
114    ;; this complex tangle enables an action to be taken when a completion is selected.
115    (:js (if on-selected (format nil "setupAutocomplete('~A', '~A');" id 
116				 (ajax-continuation (:args (value value_string id) :name "ac_finish" :keep t) 
117				   (funcall on-selected value value_string id)
118				   ))))
119
120    (:js (format nil "var ~A_auto_completer = new Ajax.Autocompleter('~A', '~A', '~A', ~A);"
121		 id
122		 id
123		 update
124		 completions-url
125		 (json:encode-json-to-string (or options :empty-dict)))))
126  )
127
128;;; In-place editor (see http://madrobby.github.com/scriptaculous/ajax-inplaceeditor/ )
129;;; :options   alist of options as defined by the underlying widget
130;;; :on-change function called with new value.
131;;; :editable? nil to turn off editing. 
132(defun in-place-field (&key (id (string (gensym "id")))
133		       name
134		       options
135		       (prompt "Click to edit.")
136		       on-change
137		       value
138		       class
139		       submit-on-blur?
140		       (editable? t)
141		       )
142  (when prompt
143    (push `("emptyText" . ,prompt) options))
144  (when submit-on-blur?
145    (push `("submitOnBlur" . "true") options))
146  (let ((current-value value))
147    (html 
148     :newline
149     ((:span :id id :if* name :name name :if* class :class class); :style "border:1px solid gray"
150      (if current-value
151	  (html (:princ current-value)))) ;was :princ-safe, but this lets you use html markup
152     (when editable?
153       (render-scripts
154	 (:js (format nil "new Ajax.InPlaceEditorWithEmptyText('~A', '~A', ~A);"
155		      id
156		      ;; :keep t permits multiple editings.
157		      (ajax-continuation (:args (value) :content-type "text/text" :name "inplace" :keep t)
158			(when on-change (funcall on-change value))
159			;; you are supposed to send the value back as the body
160			(write-string value *html-stream*))
161		      (json:encode-json-to-string (or options :empty-dict)))))))))
162
163;;; A convenience for the simple case of a setfable field
164;;; Here, on-change has different semantics, it's just a code snippet.
165(defmacro in-place-setf-field (object accessor &rest all-keys &key on-change &allow-other-keys)
166  `(in-place-field :value (,accessor ,object)
167		   :on-change #'(lambda (v) 
168				  (setf (,accessor ,object) v)
169				  ,on-change
170				  )
171		   ,@(delete-keyword-args '(:value :on-change) all-keys)
172		   ))
173
174	 
175