;; a channel to scheme code. for remote emacs access.
;; INPUT:  elisp expression
;; OUTPUT: (status . value)

;; the status is there to provide meta-data (i.e. failure, success, ...)
;; there's no escape otherwize..

; (load-library "channel")
; (channel)



;; INPUT STRINGS
(defvar channel-hash (make-hash-table))   ;; input strings

(defun channel-get-input (proc)
  (gethash proc channel-hash))

(defun channel-set-input (proc string)
  (puthash proc string channel-hash))



;; OBJECT REFERENCES
(defvar channel-objects '((dummy . -1)))  ;; unserializable objects

(defun channel-find-object (object)
  (let ((found (assoc object channel-objects)))
    (if found (cdr found) nil)))

(defun channel-register-object (object)
  (let ((previous-id (channel-find-object object)))
    (if previous-id 
	previous-id
        (let ((id (+ 1 (cdar channel-objects))))  ;; get next index 
	  (push (cons object id) channel-objects)
	  id))))


;; make sure we don't send garbage:
;; emacs objects are translated to references..
(defun channel-sanitize (expr)
  (cond
   ;; recurse
   ((consp expr) (cons (channel-sanitize (car expr))
		       (channel-sanitize (cdr expr))))
   ;; these are ok
   ((or (integerp expr)
	(symbolp  expr)
	(floatp   expr)
	(stringp  expr))  ;; strings need to be fixed for unicode etc..
    expr)

   ;; other things are replaced by refs
   (t   (cons 'ref
	      (channel-register-object expr)))))
	


;; READ
(defun channel-process-filter (channel-current string)
  (let ((in (concat 
	     (channel-get-input channel-current) 
	     string)))
    (let ((status
	   (condition-case oops
	       (progn
		 (while (not (zerop (length in)))
		   (let ((fish (read-from-string in))) 
		     (let ((expr (car fish)))
		       (set 'in (substring in (cdr fish) (length in)))
		       (eval expr))))
		 'eval-ok)
	     (error
	      (case (car oops)
		(end-of-file             ;; just wait          
		 'waiting)  
		(invalid-read-syntax     ;; byebye
		 (progn
		   (message "protocol error: closing channel")
		   (set 'channel-input "")
		   (kill-process channel-current)
		   'protocol-error))
		(t
		 (progn                  ;; other errors -> process
		   ;; (message (pp-to-string oops))
		   (channel-write-expr channel-current 'error oops)
		   oops)))))))

      (channel-set-input channel-current in)
      status)))


;; WRITE
(defun channel-write-expr (proc status expr)
  (condition-case oops
      (process-send-string proc
			   (concat
			    (pp-to-string
			     (channel-sanitize (cons status expr)))
			    "\n"))
    (error
     (message (pp-to-string oops)))))

;; START

(defun channel-process-sentinel (process event)
  (let ((name (process-name process)))
    (message
     (car (split-string
	   (format "%s : %s" name event) "\n")))))

(defun channel-start (host)
  (let ((procname (concat "channel-" host)))
    (let ((oldproc (get-process procname)))
      (if oldproc
	  (kill-process oldproc)))

    (let ((proc 
	   (if (equal host "localhost")
	       (start-process procname nil "emacs-channel")
	       (start-process procname nil "ssh" host "emacs-channel"))))
      (if (not proc)
	  (message "Can't start channel")
          (progn
	    (set-process-filter   proc 'channel-process-filter)
	    (set-process-sentinel proc 'channel-process-sentinel)
	    (channel-set-input proc "")
	    proc)))))

(defun channel (host)
  (interactive "sHost: ")
  (channel-start host))


;; SYNC OPERATION
(defun channel-reply (expr)
  (channel-write-expr channel-current ;; dynamicly scoped
		      'ok
		      expr))

(defun channel-eval (expr)
  (channel-reply (eval expr)))

(defun channel-view (identifier text)
  (with-output-to-temp-buffer identifier
    (princ text))
  (channel-reply nil))


;; ASYNC OPERATION

(defvar channel-wait-pool '())

(defun  channel-wait-push (object proc)
  (push (cons object proc) channel-wait-pool))

(defun  channel-wait-remove (object)
  (set 'channel-wait-pool 
       (remove object channel-wait-pool)))

(defun  channel-wait-get (object)
  (let ((found (assoc object channel-wait-pool)))
    (if (not found)
	nil
	(progn
	  (channel-wait-remove object)
	  (cdr found)))))


;; start an asynchronous edit. return the buffer instance, which will
;; be translated to a reference.
(defun channel-edit (identifier text)
  (let ((buffer 
	 (find-file 
	  (tempfile identifier))))  ; temp file for safety
    (insert text)
    (save-buffer)
;    (set-buffer-modified-p nil)
    (channel-wait-push buffer 
		       channel-current)))


;; finish an asynchronous edit.
;; we just need to find the process that's waiting for this object.


(defun channel-edit-done (status value)
  (let ((proc (channel-wait-get (current-buffer))))
    (if (not proc)
	(message "This is not an async edit buffer.")
        (progn
;	  (save-this-buffer nil)                 ;; save locally first!
	  (basic-save-buffer)
	  (channel-write-expr proc status value) ;; write results
	  (kill-this-buffer)))))

(defun channel-edit-reply ()
  (interactive)
  (channel-edit-done 'ok 
		     (buffer-substring-no-properties 
		      1 (+ (buffer-size) 1))))


(defun channel-edit-abort ()
  (interactive)
  (channel-edit-done 'error '(aborted)))