[clinton/lisp-on-lines.git] / src / components / ajax.lisp

(in-package :lisp-on-lines)

;;;; for when there is nothing left to display.
(defcomponent empty-page (window-component)
  ())

(defmethod render-on ((res response) (self empty-page))
  "didnt find a thing")

(defcomponent auto-complete ()
  ((input-id :accessor input-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
   (output-id :accessor output-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
   (client-value 
    :accessor client-value 
    :initform "" 
    :documentation "The string the user has, so far, insterted.")
   (index 
    :accessor index 
    :initform nil 
    :documentation "The index (for use with NTH) in list-of-values of the item selected via Ajax")
   (list-of-values 
    :accessor list-of-values 
    :initform '() 
    :documentation "The list generated by values-generator")
   (values-generator :accessor values-generator :initarg :values-generator
                     :documentation "Function which, when passed the auto-complete component, returns a list of objects.")
   (value 
    :accessor value
    :initform nil
    :documentation  "The lisp value of the object selecting in the drop down")
   (as-value :accessor as-value :initarg :as-value
             :documentation "Function which, when passed a value, returns the string to put in the text box.")
   (render :accessor render :initarg :render
           :documentation "Function which, when passed the component and one of the values render it (the value).")
   (input-size :accessor input-size :initarg :input-size :initform 20)
   (submit-on-select-p 
    :accessor submit-on-select-p 
    :initarg :submit-on-select-p 
    :initform t)
   (output-component-name :accessor output-component-name :initarg :output-comonent-name :initform 'auto-complete-output)))

(defmethod js-on-complete ((l auto-complete))
  `(lambda (transport) 
    (setf (slot-value (document.get-element-by-id ,(output-id l)) 
	   'inner-h-t-m-l)
     transport.response-text)))

(defmacro make-action-url (component action)
  "
There has got to be something like this buried in UCW somewhere, 
but here's what i use."
  `(ucw::print-uri-to-string
    (compute-url ,component 
     :action-id (ucw::make-new-action (ucw::context.current-frame *context*)
		 (lambda ()
		   (arnesi:with-call/cc
		     ,action))))))

(defun generate-ajax-request (js-url &optional js-options)
  `(new 
    (*Ajax.*Request 
     ,js-url 
     ,js-options)))

(defmacro with-ajax-request (js-url &rest js-options)
  `(generate-ajax-request-for-url 
    ,js-url
    ,@js-options))
  
(defmacro with-ajax-action ((component) &body action)
  `(generate-ajax-request
    (make-action-url ,component (progn ,@action)))) 
	
(defaction call-auto-complete ((self t) auto-complete-id value index)
    (let ((auto-complete (get-session-value (intern auto-complete-id))))
    (if auto-complete
        (if index
	    (select-value auto-complete index)
	    (call-auto-complete-from-output auto-complete auto-complete-id value self))
        (call 'empty-page :message (error "Cannot find")))))

(defaction call-auto-complete-from-output ((auto-complete auto-complete) auto-complete-id value output)
  (setf (client-value auto-complete) value)
  (let ((self output))
    (call (output-component-name auto-complete) :auto-complete auto-complete)
    (call 'empty-page :message (error "ASD"))))

(defaction select-value ((self auto-complete) index)
  (let ((index (when (< 0 (length index))
		 (parse-integer index))))
    (setf (index self) index)
    (setf (value self) (nth index (list-of-values self)))))

(defun make-auto-complete-url (input-id)
  "creates a url that calls the auto-complete entry-point for INPUT-ID."
  (format nil "auto-complete.ucw?&auto-complete-id=~A&~A=~A" 
	  input-id  ucw::+session-parameter-name+ 
	  (ucw::session.id (ucw::context.session ucw::*context*))))

(defaction on-submit ((l auto-complete))
  ())

(defmethod js-on-select ((l auto-complete))
  "the javascript that is called when an item is selected"
  (when (submit-on-select-p l)
    `(progn
      (set-action-parameter ,(register-action
			      (lambda () 
				  (arnesi:with-call/cc 
				    (on-submit l)))))
      (submit-form))))
   

(defmethod render-on ((res response) (l auto-complete))
  ;; session-values are stored in an eql hash table.
  (let ((input-key (intern (input-id l))))
    ;; We are storing the input components in the session,
    ;; keyed on the string that we also use as the id for 
    ;; the input field. 
    
    (unless (get-session-value input-key)
      (setf (get-session-value input-key) l))
    
    ;; A hidden field to hold the index number selected via javascript
    (<ucw:text :accessor (client-value l)
	       :id (input-id l) :size (input-size l))
    (<:div :id (output-id l) :class "auto-complete" (<:as-html " ")))
  (let* ((a (make-symbol (format nil "~A-autocompleter" (input-id l))))
	 (f (make-symbol (format nil "~A.select-entry-function"a))))
    (<ucw:script 
     `(setf ,a
       (new 
	(*Ajax.*Autocompleter 
	 ,(input-id l) ,(output-id l) 
	 ,(make-auto-complete-url (input-id l))
	 (create
	  :param-name "value"))))
     `(setf ,f (slot-value ,a 'select-entry))
     `(setf (slot-value ,a 'select-entry)
       (lambda () 
	 (,f)
	 ,(generate-ajax-request
	   (make-auto-complete-url (input-id l))
	   `(create 
	     :parameters (+ "&index=" (slot-value ,a 'index))
	     :method "post"
	     :on-complete (lambda (res)
			    ,(js-on-select l)))))))))
     

;;;; * auto-complete-ouput 


(defcomponent auto-complete-output (window-component)
  ((auto-complete :initarg :auto-complete :accessor auto-complete)))

(defmethod render-on ((res response) (output auto-complete-output))
  (let ((auto-complete (auto-complete output)))
    (setf (list-of-values auto-complete)
	  (funcall (values-generator auto-complete) (client-value auto-complete)))
    (<:ul 
     :class "auto-complete-list" 
     (arnesi:dolist* (value (list-of-values auto-complete))
       (<:li 
	:class "auto-complete-list-item"
	(funcall (render auto-complete) value))))))

(defcomponent fkey-auto-complete (auto-complete)
  ())

(defmethod js-on-select ((self fkey-auto-complete))
  (with-ajax-action (self)
    (mewa::sync-foreign-instance (ucw::parent self) (value self))))

(defslot-presentation ajax-foreign-key-slot-presentation (mewa::foreign-key-slot-presentation)
  ((original-value :accessor original-value :initform nil) 
   (search-slots :accessor search-slots :initarg :search-slots :initform nil)
   (live-search 
     :accessor live-search
     :component fkey-auto-complete))
  (:type-name ajax-foreign-key))


(defmethod shared-initialize :after ((slot ajax-foreign-key-slot-presentation) slots &rest args)
  (let* ((l (live-search slot))
	 (slot-name (slot-name slot))
	 (instance (instance (ucw::parent slot)))
	 (foreign-instance (explode-foreign-key instance slot-name))
	 (class-name (class-name
		      (class-of foreign-instance))))
    ;; If no search-slots than use the any slots of type string
    (unless (search-slots slot)
      (setf (search-slots slot) (find-slots-of-type foreign-instance)))

    (setf (lisp-on-lines::values-generator l) 
	  (lambda (input)
	    (word-search class-name  
			 (search-slots slot)  input)))
		    
    (setf (lisp-on-lines::render l)
	  (lambda (val) 
	    (<ucw:render-component 
	     :component (make-presentation val :type :one-line))))))
	  
(defaction revert-foreign-slot ((slot ajax-foreign-key-slot-presentation))
  (setf (lol::value (live-search slot)) nil)
  (when (original-value slot)
  (mewa::sync-foreign-instance slot (original-value slot))))

(defmethod present-slot :around ((slot ajax-foreign-key-slot-presentation) instance)

  (let ((foreign-instance 
	 (if (lol::value (live-search slot))
	     (lol::value (live-search slot))
	     (setf (original-value slot)
		   (when (presentation-slot-value slot instance) 
		     (meta-model:explode-foreign-key instance (slot-name slot)))))))
    
    (flet ((render () (when foreign-instance (call-next-method))))
      (if (slot-boundp slot 'ucw::place)
	  (cond 
	    ((editablep slot)
	     (when  foreign-instance
	       (setf (client-value (live-search slot))
		     (with-output-to-string (s)
		       (yaclml:with-yaclml-stream s 
			 (present (make-presentation foreign-instance
						     :type :one-line))))))
	    
	     (<ucw:render-component :component (live-search slot))
	     #+ (or) (<ucw:submit :action (revert-foreign-slot slot)
			  :value "Undo")
			      (<ucw:submit :action  (mewa::search-records slot instance) :value "find" :style "display:inline"))
	    ((mewa::linkedp slot)
	     (<ucw:a :action (mewa::view-instance slot foreign-instance) 
		     (render)))
	    (t       
	     (render)))
	  ;; presentation is used only for rendering
	  (render)))))
Commit	Line	Data
3b18c689 DC	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+))
21d89532 DC	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")
3b18c689 DC	25	(values-generator :accessor values-generator :initarg :values-generator
3b18c689 DC	26	:documentation "Function which, when passed the auto-complete component, returns a list of objects.")
21d89532 DC	27	(value
	28	:accessor value
	29	:initform nil
	30	:documentation "The lisp value of the object selecting in the drop down")
3b18c689 DC	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)
21d89532 DC	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)))
3b18c689 DC	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
21d89532	59	(defun generate-ajax-request (js-url &optional js-options)
3b18c689 DC	60	`(new
3b18c689 DC	61	(Ajax.Request
21d89532 DC	62	,js-url
21d89532 DC	63	,js-options)))
3b18c689	64
21d89532 DC	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)
3b18c689 DC	75	(let ((auto-complete (get-session-value (intern auto-complete-id))))
3b18c689 DC	76	(if auto-complete
21d89532 DC	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")))))
3b18c689 DC	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))
21d89532	85	(call (output-component-name auto-complete) :auto-complete auto-complete)
3b18c689 DC	86	(call 'empty-page :message (error "ASD"))))
3b18c689 DC	87
21d89532 DC	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)))))
3b18c689	93
21d89532 DC	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
3b18c689	113
3b18c689 DC	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
3b18c689 DC	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))))
21d89532	129	(f (make-symbol (format nil "~A.select-entry-function"a))))
3b18c689 DC	130	(<ucw:script
	131	`(setf ,a
	132	(new
	133	(Ajax.Autocompleter
	134	,(input-id l) ,(output-id l)
21d89532	135	,(make-auto-complete-url (input-id l))
3b18c689 DC	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)
21d89532 DC	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)))))))))
3b18c689 DC	149
3b18c689 DC	150
3b18c689 DC	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)))
21d89532	159	(setf (list-of-values auto-complete)
3b18c689 DC	160	(funcall (values-generator auto-complete) (client-value auto-complete)))
	161	(<:ul
	162	:class "auto-complete-list"
21d89532	163	(arnesi:dolist* (value (list-of-values auto-complete))
3b18c689 DC	164	(<:li
	165	:class "auto-complete-list-item"
	166	(funcall (render auto-complete) value))))))
	167
3b18c689 DC	168	(defcomponent fkey-auto-complete (auto-complete)
	169	())
	170
	171	(defmethod js-on-select ((self fkey-auto-complete))
	172	(with-ajax-action (self)
21d89532	173	(mewa::sync-foreign-instance (ucw::parent self) (value self))))
3b18c689 DC	174
3b18c689 DC	175	(defslot-presentation ajax-foreign-key-slot-presentation (mewa::foreign-key-slot-presentation)
21d89532 DC	176	((original-value :accessor original-value :initform nil)
21d89532 DC	177	(search-slots :accessor search-slots :initarg :search-slots :initform nil)
3b18c689 DC	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
21d89532 DC	205	(defaction revert-foreign-slot ((slot ajax-foreign-key-slot-presentation))
21d89532 DC	206	(setf (lol::value (live-search slot)) nil)
d5e996b3 DC	207	(when (original-value slot)
d5e996b3 DC	208	(mewa::sync-foreign-instance slot (original-value slot))))
21d89532 DC	209
21d89532 DC	210	(defmethod present-slot :around ((slot ajax-foreign-key-slot-presentation) instance)
d5e996b3	211
21d89532 DC	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))
adfb3983	231	#+ (or) (<ucw:submit :action (revert-foreign-slot slot)
21d89532 DC	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)))))